Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch core-8-4-branch Through [79f92d79b1] Excluding Merge-Ins
This is equivalent to a diff from 5b384d430a to 79f92d79b1
|
2007-06-10
| ||
| 21:11 | * README: updated links. [Bug 1715081] check-in: 6ddf3a1aec user: hobbs tags: core-8-4-branch | |
|
2007-06-06
| ||
| 09:54 | * unix/configure.in (Darwin): add plist for tclsh; link the * unix/Makefile.in (Darwin): Tcl an... check-in: 79f92d79b1 user: das tags: core-8-4-branch | |
|
2007-06-05
| ||
| 17:54 | * tests/result.test (result-6.2): Add test for Bug 1649062 so that 8.4 and 8.5... check-in: 0c1b05bd40 user: dgp tags: core-8-4-branch | |
|
2003-03-06
| ||
| 23:24 | * generic/TclUtf.c (Tcl_UniCharNcasecmp): Corrected failure to * tests/utf.te... check-in: 8003bbacd1 user: dgp tags: core-8-4-branch | |
|
2003-03-04
| ||
| 23:45 | * README: Bumped version number of * generic/tcl.h: ... check-in: a5f8f0d439 user: dgp tags: trunk | |
|
2003-03-03
| ||
| 20:22 | Mac OS Classic specific fixes: * generic/tclIOUtil.c (TclNewFSPathObj): on TCL_PLATFORM_MAC, skip... check-in: 5b384d430a user: das tags: trunk, core-8-4-2 | |
| 20:04 | mark Mar 3 date for 8.4.2 check-in: 41131d3163 user: hobbs tags: trunk | |
Changes to ChangeLog.
1 2 3 4 5 6 7 | 2003-03-03 Jeff Hobbs <jeffh@ActiveState.com> *** 8.4.2 TAGGED FOR RELEASE *** 2003-03-03 Daniel Steffen <das@users.sourceforge.net> Mac OS Classic specific fixes: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 |
2007-06-06 Daniel Steffen <das@users.sourceforge.net>
* unix/configure.in (Darwin): add plist for tclsh; link the
* unix/Makefile.in (Darwin): Tcl and tclsh plists into their
* macosx/Tclsh-Info.plist.in (new): binaries in all cases.
* unix/tcl.m4 (Darwin): fix CF checks in fat 32&64bit builds.
* unix/configure: autoconf-2.13
2007-06-05 Don Porter <dgp@users.sourceforge.net>
* tests/result.test (result-6.2): Add test for Bug 1649062 so
that 8.4 and 8.5 both test the same outcome and we verify compatibility.
2007-05-30 Don Porter <dgp@users.sourceforge.net>
* README: Bump version number to 8.4.16
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure.in:
* unix/configure: autoconf-2.13
* win/configure:
2007-05-29 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixThrd.c (Tcl_JoinThread): fix for 64-bit handling of
pthread_join exit return code storage. [Bug 1712723]
2007-05-24 Don Porter <dgp@users.sourceforge.net>
*** 8.4.15 TAGGED FOR RELEASE ***
* generic/tclIO.c: Backport memleak fix in TclFinalizeIOSubsystem.
2007-05-17 Don Porter <dgp@users.sourceforge.net>
* tests/fCmd.test: Backport the notNetworkFilesystem constraint.
2007-05-15 Don Porter <dgp@users.sourceforge.net>
* generic/tclNamesp.c: Plugged memory leak related to
[namespace delete ::]. [Bug 1716782]
* changes: updates for 8.4.15 release.
* win/tclWinReg.c: Bump to registry 1.1.5 to account
* library/reg/pkgIndex.tcl: for [1682211] bug fix.
2007-05-10 Don Porter <dgp@users.sourceforge.net>
* generic/tclInt.h: TclFinalizeThreadAlloc() is always defined,
so make sure it is also always declared.
[Tcl Bug 1706140]
* generic/tclCmdMZ.c (Trace*Proc): Update Tcl_VarTraceProcs so
* generic/tclLink.c (LinkTraceProc): that they call
* generic/tclUtil.c (TclPrecTraceProc): Tcl_InterpDeleted() for
themselves, and do not rely on (frequently buggy) setting of the
TCL_INTERP_DESTROYED flag by the trace core.
* generic/tclVar.c: Update callers of CallVarTraces to not
pass in the TCL_INTERP_DESTROYED flag. Also apply filters so that
public routines only pass documented flag values down to lower level
routines.
* generic/tclVar.c (CallVarTraces): The setting of the
TCL_INTERP_DESTROYED flag is now done entirely within the
CallVarTraces routine, the only place it can be done right.
2007-04-30 Daniel Steffen <das@users.sourceforge.net>
* unix/Makefile.in: add 'tclsh' dependency to install targets that rely
on tclsh, fixes parallel 'make install' from empty build dir.
2007-04-29 Daniel Steffen <das@users.sourceforge.net>
* unix/tclUnixFCmd.c: add workaround for crashing bug in fts_open()
* unix/tclUnixInit.c: without FTS_NOSTAT on 64bit Darwin 8 or earlier.
* unix/tclLoadDyld.c (TclpLoadMemory): fix (void*) arithmetic.
* macosx/tclMacOSXNotify.c: fix warnings.
* macosx/README: sync whitespace/formatting with HEAD.
* macosx/tclMacOSXBundle.c:
* macosx/tclMacOSXNotify.c:
* unix/tclLoadDyld.c:
* macosx/Makefile: fix/add copyright and license refs.
* macosx/tclMacOSXBundle.c:
* macosx/Tcl-Info.plist.in:
* unix/Makefile.in (dist): copy license.terms to dist macosx dir.
* unix/configure.in: install license.terms into Tcl.framework.
* unix/configure: autoconf-2.13
2007-04-21 Kevin B. Kenny <kennyb@acm.org>
* generic/tclClock.c: Restored Cygwin buildability [Bug 1387154]
* generic/tclInt.decls: Yet another round of attempting
* generic/tclInt.h: to get the correct type signature
* unix/tclUnixPort.h: for TclpLocaltime and TclpGmtime.
* unix/tclUnixTime.c: CONST TclpTime_t is a 'time_t *CONST'
* win/tclWinTime.c: and not a 'CONST time_t*' [Bug 1677275]
* generic/tclIntDecls.h:
* generic/tclIntPlatDecls.h: Regenerated.
2007-03-24 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* win/tclWinThrd.c: Thread exit handler marks the current
thread as un-initialized. This allows exit handlers that
are registered later to re-initialize this subsystem in
case they need to use some sync primitives (cond variables)
from this file again.
2007-03-19 Don Porter <dgp@users.sourceforge.net>
* generic/tclEvent.c (Tcl_CreateThread): Replaced some calls to
* generic/tclPkg.c (CheckVersion): Tcl_Alloc() with calls to
* unix/tclUnixTime.c (SetTZIfNecessary): ckalloc(), which better
* win/tclAppInit.c (setargv): supports memory debugging.
2007-03-17 Kevin Kenny <kennykb@acm.org>
* win/tclWinReg.c (GetKeyNames): Size the buffer for enumerating
key names correctly, so that Unicode names exceeding 127 chars
can be retrieved without crashing. [Bug 1682211]
* tests/registry.test (registry-4.9): Added test case for the
above bug.
2007-03-13 Don Porter <dgp@users.sourceforge.net>
* generic/tclExecute.c (INST_FOREACH_STEP4): Re-fetch pointers for
* tests/foreach.test (foreach-10.1): the value list each iteration
of the loop as defense against shimmers. [Bug 1671087]
* generic/tclVar.c (TclArraySet): Re-fetch pointers for the list
* tests/var.test (var-17.1): argument of [array set] each time
through the loop as defense against possible shimmer issues.
[Bug 1669489].
2007-03-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclCmdIL.c (Tcl_LsortObjCmd): Handle tricky case with loss
* tests/cmdIL.test (cmdIL-1.29):of list rep during sorting due
to shimmering. [Bug 1675116]
2007-03-07 Daniel Steffen <das@users.sourceforge.net>
* macosx/tclMacOSXNotify.c: add spinlock debugging and sanity checks.
* unix/tcl.m4 (Darwin): s/CFLAGS/CPPFLAGS/ in macosx-version-min check.
* unix/configure: autoconf-2.13
2007-03-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclCompCmds.c (TclCompileForeachCmd): Prevent an unexpected
* tests/foreach.test (foreach-9.1): infinite loop when the
variable list is empty and the foreach is compiled. [Bug 1671138]
2007-02-22 Andreas Kupries <andreask@activestate.com>
* tests/pkg.test: Added tests for the case of an alpha package
satisfying a require for the regular package, demonstrating a
corner case specified in TIP#280. More notes in the comments to
the test.
2007-02-20 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n: Typo fix. [Bug 1663539]
2007-02-19 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIOUtil.c (Tcl_FSEvalFile): safe incr of objPtr ref.
* unix/tcl.m4: use SHLIB_SUFFIX=".so" on HP-UX ia64 arch.
* unix/configure: autoconf-2.13
2007-02-12 Andreas Kupries <andreask@activestate.com>
* generic/tclEncoding.c (EscapeFromUtfProc): Applied patch
supplied by Mo DeJong to fix [Bug 1516109]. Backport from Tcl
8.5. Mo's description: Clear the TCL_ENCODING_END flag when end
bytes are written. This fix keep this method from writing escape
bytes for an encoding like iso2022-jp multiple times when the
escape byte overlap with the end of the IO buffer.
* tests/io.test: Add test case for escape byte overlap case.
2007-02-04 Daniel Steffen <das@users.sourceforge.net>
* unix/configure.in: add caching to -pipe check.
* unix/configure: autoconf-2.13
2007-01-30 Jeff Hobbs <jeffh@ActiveState.com>
* win/Makefile.in (install-private-headers): added target
2007-01-29 Don Porter <dgp@users.sourceforge.net>
* doc/fcopy.n: Typo fix. [Bug 1630627]
2007-01-25 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4: integrate CPPFLAGS into CFLAGS as late as possible
* unix/configure.in: and move (rather than duplicate) -isysroot flags
from CFLAGS to CPPFLAGS to avoid errors about multiple -isysroot flags
from some older gcc builds.
* unix/configure: autoconf-2.13
2007-01-22 Andreas Kupries <andreask@activestate.com>
* compat/memcmp.c (memcmp): Fixed the VOID / CONST typo introduced
by the last checkin.
2007-01-22 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* compat/memcmp.c (memcmp): Reworked so that arithmetic is never
performed upon void pointers, since that is illegal. [Bug 1631017]
2006-01-19 Daniel Steffen <das@users.sourceforge.net>
* macosx/tclMacOSXNotify.c: accommodate changes to prototypes of
OSSpinLock(Un)Lock API.
* tests/env.test: add extra system env vars that need to be preserved
on some Mac OS X versions for testsuite to work.
* unix/tcl.m4: ensure CPPFLAGS env var is used when set. [Bug 1586861]
(Darwin): add -isysroot and -mmacosx-version-min flags to CPPFLAGS when
present in CFLAGS to avoid discrepancies between what headers configure
sees during preprocessing tests and compiling tests.
* unix/configure: autoconf-2.13
2006-12-19 Daniel Steffen <das@users.sourceforge.net>
* unix/tclUnixThrd.c (TclpInetNtoa): fix for 64 bit.
* unix/tcl.m4 (Darwin): --enable-64bit: verify linking with 64bit -arch
flag succeeds before enabling 64bit build.
* unix/configure: autoconf-2.13
2006-12-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/string.n: Fix example. [Bug 1615277]
2006-12-05 Andreas Kupries <andreask@activestate.com>
* tests/pkg.test: Backport to 8.4 (Don Porter's work):
* generic/tclPkg.c: When no requirements are supplied to a [package
require $pkg] and [package unknown] is invoked to find a satisfying
package, pass the requirement argument "0-" (which means all versions
are acceptable). This permits a registered [package unknown] command
to call [package vsatisfies $testVersion {*}$args] without any special
handling of the empty $args case. This fixes/avoids a bug in
[::tcl::tm::UnknownHandler] that was causing old TM versions to be
provided in preference to newer TM versions. Thanks to Julian Noble
for discovering the issue.
2006-12-04 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/file.n: Fix confusing wording for [file pathtype]. [Bug 1606454]
2006-11-28 Andreas Kupries <andreask@activestate.com>
* generic/tclBasic.c: TIP #280 implementation, conditional on the
* generic/tclCmdAH.c: define TCL_TIP280.
* generic/tclCmdIL.c:
* generic/tclCmdMZ.c:
* generic/tclCompCmds.c:
* generic/tclCompExpr.c:
* generic/tclCompile.c:
* generic/tclCompile.h:
* generic/tclExecute.c:
* generic/tclIOUtil.c:
* generic/tclInt.h:
* generic/tclInterp.c:
* generic/tclNamesp.c:
* generic/tclObj.c:
* generic/tclProc.c:
* tests/compile.test:
* tests/info.test:
* tests/platform.test:
* tests/safe.test:
2006-11-27 Kevin Kenny <kennykb@acm.org>
* unix/tclUnixChan.c (TclUnixWaitForFile):
* tests/event.test (event-14.*): Corrected a bug where
TclUnixWaitForFile would present select() with the wrong mask on an
LP64 machine if a fd number exceeds 32. Thanks to Jean-Luc Fontaine
for reporting and diagnosing [Bug 1602208]
2006-11-26 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4 (Linux): --enable-64bit support. [Patch 1597389]
* unix/configure: autoconf-2.13 [Bug 1230558]
2006-11-07 Andreas Kupries <andreask@activestate.com>
* unix/tclUnixFCmd.c (CopyFile): Added code to fall back to a
hardwired default block size should the filesystem report a bogus
value. [Bug 1586470]
2006-11-03 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c (TEOVI): fix for possible leak of a Command in
the presence of execution traces that delete it.
* generic/tclBasic.c (TEOVI):
* tests/trace.test (trace-21.11): fix for [Bug 1590232], execution
traces may cause a second command resolution in the wrong
namespace.
2006-11-01 Daniel Steffen <das@users.sourceforge.net>
* generic/tclEnv.c (Darwin): mark _environ symbol as unexported.
2006-10-31 Pat Thoyts <patthoyts@users.sourceforge.net>
* rules.vc: Fix [Bug 1582769] build with VC2003 and correct i386 arch
2006-10-23 Don Porter <dgp@users.sourceforge.net>
* README: Bump version number to 8.4.15
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure.in:
* unix/configure: autoconf-2.13
* win/configure:
2006-10-18 Pat Thoyts <patthoyts@users.sourceforge.net>
*** 8.4.14 TAGGED FOR RELEASE ***
* win/nmakehlp.c: Ensure builds with VC6 without Platform SDK.
* win/rules.vc: Pickup MACHINE from environment.
2006-10-17 Don Porter <dgp@users.sourceforge.net>
* generic/tclIOUtil.c: Cleaned up some code flagged by a
* generic/tclInt.h: `make checkexports` test.
* win/tclWin32Dll.c:
* win/tclWinFile.c:
2006-10-16 Daniel Steffen <das@users.sourceforge.net>
* changes: updates for 8.4.14 release.
* macosx/Makefile: don't redo prebinding of non-prebound binaires.
2006-10-11 Andreas Kupries <andreask@activestate.com>
* generic/tclPkg.c (Tcl_PkgRequireEx): Corrected crash when argument
version==NULL passed in. Backport of the fix for the same problem in
8.5.
2006-10-10 Don Porter <dgp@users.sourceforge.net>
* changes: changes updated for 8.4.14 release.
2006-10-06 Jeff Hobbs <jeffh@ActiveState.com>
* tests/http.test: update tests to handle strictness change.
2006-10-06 Pat Thoyts <patthoyts@users.sourceforge.net>
* win/rules.vc: avoid /RTCc flag with MSVC8. [Bug 1571954]
2006-10-05 Jeff Hobbs <jeffh@ActiveState.com>
* library/http/http.tcl (http::geturl): only do geturl url rfc 3986
validity checking if $::http::strict is true (default false for 8.4).
[Bug 1560506]
* generic/tcl.h: note limitation on changing Tcl_UniChar size
* generic/tclEncoding.c (UtfToUnicodeProc, UnicodeToUtfProc):
* tests/encoding.test (encoding-16.1): fix alignment issues in
unicode <> utf conversion procs. [Bug 1122671]
2006-10-05 Miguel Sofer <msofer@users.sf.net>
* generic/tclVar.c (Tcl_LappendObjCmd):
* tests/append.test(4.21-22): fix for longstanding [Bug 1570718],
lappending nothing to non-list. Reported by lvirden
2006-10-02 Don Porter <dgp@users.sourceforge.net>
* generic/tclFileName.c (TclGlob): Prevent doubling of directory
separators by [glob]. [Bug 1569042]
2006-10-01 Pat Thoyts <patthoyts@users.sourceforge.net>
* win/tclWinFile.c: Handle possible missing define.
* win/tclWinFile.c: Backported fix for [Bug 1420432] (cannot set
* tests/cmdAH.test: mtime for directories on windows).
2006-09-30 Miguel Sofer <msofer@users.sf.net>
* generic/tclUtil.c (Tcl_SplitList): optimisation, [Patch 1344747]
by dgp.
2006-09-26 Pat Thoyts <patthoyts@users.sourceforge.net>
* win/makefile.vc: Updated MSVC build to properly deal with
* win/nmakehlp.c: MSVC8 and AMD64 target. Backport from 8.5
* win/rules.vc:
* generic/tcl.h: Fixed stat definition for MSVC8 AMD64.
* win/tclWinSock.c: Casting type police.
* win/tclWinTime.c:
2006-09-26 Don Porter <dgp@users.sourceforge.net>
* generic/tcl.h: As 2006-09-22 commit from Donal K. Fellows
demonstrates, "#define NULL 0" is just wrong, and as a quotable chat
figure observed, "If NULL isn't defined, we're not using a C compiler."
Improper fallback definition of NULL removed.
2006-09-25 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.c (Tcl_StackChannel): Fixed [SF Tcl Bug 1564642], aka
coverity #51. Extended loop condition, added checking for NULL to
prevent seg.fault.
2006-09-25 Andreas Kupries <andreask@activestate.com>
* generic/tclBasic.c: Reverted exposure of patchlevel in registered
core version when TIP#268 features are activated. Better compatibility
with existing packages. Like Tk.
2006-09-24 Miguel Sofer <msofer@users.sf.net>
* generic/tclParse.c (Tcl_ParseCommand): also return an error if
start==NULL and numBytes<0. This is coverity's bug #20
* generic/tclStringObj.c (STRING_SIZE): fix allocation for 0-length
strings. This is coverity's bugs #54-5
2006-09-22 Andreas Kupries <andreask@activestate.com>
* generic/tclInt.h: Moved TIP#268's field 'packagePrefer' to the end
of the structure, for better backward compatibility.
2006-09-22 Andreas Kupries <andreask@activestate.com>
* generic/tclPkg.c (Tcl_PkgRequireEx): Changes handling of the return
information from 'Tcl_PkgRequireProc'. Keep the interpreter result
empty. Backport of fix for problem found while testing #268 under 8.5.
More details in the comments.
2006-09-22 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclThreadTest.c (TclCreateThread): Use NULL instead of 0 as
end-of-strings marker to Tcl_AppendResult; the difference matters on
64-bit machines. [Bug 1562528]
2006-09-21 Andreas Kupries <andreask@activestate.com>
* generic/tcl.decls: Implemented TIP #268, conditionally.
* generic/tclBasic.c: Define TCL_TIP268 to activate the new
* generic/tclDecls.h: features.
* generic/tclInt.h:
* generic/tclPkg.c:
* generic/tclStubInit.c:
* generic/tclTest.c:
* library/init.tcl
* library/package.tcl:
* tests/pkg.test:
* tests/platform.test:
* tests/safe.test:
* doc/PkgRequire.3:
2006-09-15 Jeff Hobbs <jeffh@ActiveState.com>
* library/http/http.tcl: Change " " -> "+" url encoding mapping
* library/http/pkgIndex.tcl: to " " -> "%20" as per RFC 3986.
* tests/http.test (http-5.1): bump http to 2.5.3 for 8.4.14
2006-09-12 Andreas Kupries <andreask@activestate.com>
* unix/configure.in (HAVE_MTSAFE_GETHOST*): Modified to recognize
HP-UX 11.00 and beyond as having mt-safe implementations of the
gethost functions.
* unix/configure: Regenerated, using autoconf 2.13
* unix/tclUnixCompat.c (PadBuffer): Fixed bug in calculation of the
increment needed to align the pointer, and added documentation
explaining why the macro is implemented as it is.
2006-09-11 Andreas Kupries <andreask@activestate.com>
* tests/msgcat.test: Bumped version in auxiliary files as well.
* doc/msgcat.n:
2006-09-11 Daniel Steffen <das@users.sourceforge.net>
* unix/tclUnixCompat.c: make compatLock static and only declare it
when it will actually be used; #ifdef parts of TSD that are not always
needed; adjust #ifdefs to cover all possible cases; fix whitespace.
2006-09-10 Don Porter <dgp@users.sourceforge.net>
* library/msgcat/msgcat.tcl: Bump to version msgcat 1.3.4 to account
* library/msgcat/pkgIndex.tcl: for modifications.
2006-09-10 Daniel Steffen <das@users.sourceforge.net>
* library/msgcat/msgcat.tcl (msgcat::Init): on Darwin, add fallback of
* tests/msgcat.test: default msgcat locale to
* unix/tclUnixInit.c (TclpSetVariables): current CFLocale
identifier if available (via private ::tcl::mac::locale global, set at
interp init when on Mac OS X 10.3 or later with CoreFoundation).
* unix/tcl.m4: add caching to new SC_TCL_* macros for MT-safe wrappers
* unix/configure: autoconf-2.13
2006-09-08 Andreas Kupries <andreask@activestate.com>
* unix/tclUnixCompat.c: Fixed conditions for CopyArray/CopyString, and
CopyHostent. Also fixed bad var names in TclpGetHostByName.
2006-09-08 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* unix/tclUnixCompat.c: Added fallback to gethostbyname() and
gethostbyaddr() if the implementation is known to be MT-safe
(currently for Darwin 6 or later only).
* unix/configure.in: Assume gethostbyname() and gethostbyaddr() are
MT-safe starting with Darwin 6 (Mac OSX 10.2).
* unix/configure: Regenerated with autoconf V2.13
2006-09-07 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* unix/tclUnixFCmd.c: Removed some false tests added (and left by
mistake) by fixing [Bug 999544]
* unix/tclUnixCompat.c: Added fallback to MT-unsafe library calls if
TCL_THREADS is not defined. Fixed alignment of arrays copied by
CopyArrayi() to be on the sizeof(char *) boundary.
2006-09-07 Andreas Kupries <andreask@activestate.com>
* unix/configure: Regenerated using autoconf 2.13.
2006-09-07 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* unix/tclUnixChan.c Rewritten MT-safe wrappers to
* unix/tclUnixCompat.c return ptrs to TSD storage
* unix/tclUnixFCmd.c making them all look like their
* unix/tclUnixPort.h MT-unsafe pendants API-wise.
* unix/tclUnixSock.c
2006-09-06 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* unix/tclUnixChan.c: Added TCL_THREADS ifdef'ed usage
* unix/tclUnixFCmd.c: of MT-safe calls like:
* unix/tclUnixSock.c: getpwuid, getpwnam, getgrgid, getgrnam,
* unix/tclUnixPort.h: gethostbyname and gethostbyaddr.
* unix/Makefile.in: See Tcl Bug: 999544
* unix/configure.in:
* unix/tcl.m4:
* unix/configure: Regenerated.
* unix/tclUnixCompat.c: New file containing MT-safe implementation of
some library calls.
2006-09-04 Don Porter <dgp@users.sourceforge.net>
* tests/main.text (Tcl_Main-4.4): Test corrected to not be
timing sensitive to the Bug 1481986 fix. [Bug 1550858]
2006-09-04 Jeff Hobbs <jeffh@ActiveState.com>
* doc/package.n: correct package example
2006-08-30 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinChan.c: [Bug 819667] Improve logic for identifying COM
ports.
* win/tclWinFCmd.c: [Bug 1548263] Added test for NULL return
* generic/tclIOUtil.c: from Tcl_FSGetNormalizedPath which was
causing segv's
* generic/tclFileName.c (TclDoGlob): match incr with existing decr.
* unix/Makefile.in: add valgrindshell target and update default
VALGRINDARGS. User can override, or add to it with VALGRIND_OPTS env
var.
* generic/tclBasic.c (Tcl_CreateInterp): init iPtr->threadId
* generic/tclIOGT.c (ExecuteCallback):
* generic/tclPkg.c (Tcl_PkgRequireEx): replace Tcl_GlobalEval(Obj)
with more efficient Tcl_Eval(Obj)Ex
2006-08-22 Andreas Kupries <andreask@activestate.com>
* unix/tclUnixNotfy.c (Tcl_WaitForEvent): Fixed broken if syntax
committed 2006-08-21 by Daniel. The broken syntax is visible to all
unix platforms, but not on OSX for machines which HAVE_COREFOUNDATION.
2006-08-21 Don Porter <dgp@users.sourceforge.net>
* generic/tclIOUtil.c: Revisions to complete the thread finalization
of the cwdPathPtr. [Bug 1536142]
2006-08-21 Daniel Steffen <das@users.sourceforge.net>
* macosx/tclMacOSXNotify.c (Tcl_WaitForEvent): if the run loop is
already running (e.g. if Tcl_WaitForEvent was called recursively),
re-run it in a custom run loop mode containing only the source for the
notifier thread, otherwise wakeups from other sources added to the
common run loop modes might get lost; sync panic msg changes from
HEAD.
* unix/tclUnixNotfy.c (Tcl_WaitForEvent): on 64-bit Darwin,
pthread_cond_timedwait() appears to have a bug that causes it to wait
forever when passed an absolute time which has already been exceeded
by the system time; as a workaround, when given a very brief timeout,
just do a poll on that platform. [Bug 1457797]
* unix/tclUnixPort.h (Darwin): override potentially faulty configure
detection of termios availability in all cases, since termios is known
to be present on all Mac OS X releases since 10.0. [Bug 497147]
2006-08-18 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4 (Darwin): add support for --enable-64bit on x86_64, for
universal builds including x86_64, for 64-bit CoreFoundation on
Leopard and for use of -mmacosx-version-min instead of
MACOSX_DEPLOYMENT_TARGET.
* unix/configure: autoconf-2.13
* generic/tcl.h: add fixes for building on Leopard and support
* unix/tclUnixPort.h: for 64-bit CoreFoundation on Leopard.
* unix/tclUnixPort.h: on Darwin x86_64, disable use of vfork as it
causes execve to fail intermittently. (rdar://4685553)
* macosx/README: updates for x86_64 support and Xcode 2.4.
* unix/tclUnixChan.c (TclUnixWaitForFile): with timeout < 0, if
select() returns early (e.g. due to a signal), call it again instead
of returning a timeout result. Fixes intermittent event-13.8 failures.
2006-08-09 Don Porter <dgp@users.sourceforge.net>
* generic/tclEncoding.c: Replace buffer copy in for loop with
call to memcpy(). Thanks to afredd. [Patch 1530262]
2006-08-03 Daniel Steffen <das@users.sourceforge.net>
* unix/tclUnixPipe.c (TclpCreateProcess): for USE_VFORK: ensure
standard channels are initialized before vfork() so that the child
doesn't potentially corrupt global state in the parent's address
space.
2006-07-30 Kevin Kenny <kennykb@acm.org>
* tests/clock.test: Allowed UTC as a synonym for GMT in two tests that
indirectly invoke 'strftime' with the result of 'gmtime' to fix a
bogus test failure on FreeBSD systems. [Bug 1513489]
2006-07-30 Joe English <jenglish@users.sourceforge.net>
* doc/AppInit.3: Fix typo [Bug 1496886]
2006-07-20 Daniel Steffen <das@users.sourceforge.net>
* macosx/tclMacOSXNotify.c (Tcl_InitNotifier, Tcl_WaitForEvent):
create notifier thread lazily upon first call to Tcl_WaitForEvent()
rather than in Tcl_InitNotifier(). Allows calling exeve() in processes
where the event loop has not yet been run (Darwin's execve() fails in
processes with more than one thread), in particular allows embedders
to call fork() followed by execve(), previously the pthread_atfork()
child handler's call to Tcl_InitNotifier() would immediately recreate
the notifier thread in the child after a fork.
* macosx/tclMacOSXNotify.c (Tcl_InitNotifier): add support for
* unix/tclUnixFCmd.c (DoRenameFile, CopyFileAtts): weakly importing
* unix/tclUnixInit.c (TclpSetInitialEncodings): symbols not
available on OSX 10.2 or 10.3, enables binaires built on later OSX
versions to run on earlier ones.
* macosx/README: document how to enable weak-linking; cleanup.
* unix/tclUnixPort.h: add support for weak-linking; conditionalize
AvailabilityMacros.h inclusion; only disable realpath on 10.2 or
earlier when threads are enabled.
* unix/tclLoadDyld.c (TclpLoadMemoryGetBuffer): change runtime Darwin
* unix/tclUnixInit.c (TclpInitPlatform): release check to use
global initialized once
* unix/tclUnixFCmd.c (DoRenameFile, TclpObjNormalizePath): add runtime
Darwin release check to determine if realpath is threadsafe.
* unix/configure.in: add check on Darwin for compiler support of weak
* unix/tcl.m4: import and for AvailabilityMacros.h header; move
Darwin specific checks & defines that are only relevant to the tcl
build out of tcl.m4; restrict framework option to Darwin; cleanup
quoting.
* unix/configure: autoconf-2.13
* unix/tclLoadDyld.c (TclpLoadMemory):
* unix/tclUnixPipe.c (TclpCreateProcess): fix signed-with-unsigned
comparison and other warnings from gcc4 -Wextra.
2006-07-13 Andreas Kupries <andreask@activestate.com>
* unix/tclUnixPort.h: Added the inclusion of <AvailabilityMacros.h>.
The missing header caused the upcoming #if conditions to wrongly
exclude realpath, causing file normalize to ignore symbolic links in
the path.
2006-07-11 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* generic/tclAsync.c: Made Tcl_AsyncDelete() more tolerant when called
after all thread TSD has been garbage-collected.
2006-07-10 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIO.c (Tcl_CreateChannel): allow Tcl std channel
inheritance to be #defined out (default remains in).
2006-06-15 Don Porter <dgp@users.sourceforge.net>
* changes: changes to start prep for an 8.4.14 release.
2006-06-14 Daniel Steffen <das@users.sourceforge.net>
* unix/tclUnixPort.h (Darwin): support for MAC_OS_X_VERSION_MAX_ALLOWED
define from AvailabilityMacros.h: override configure detection and only
use API available in the indicated OS version or earlier.
2006-06-14 Pat Thoyts <patthoyts@users.sourceforge.net>
* generic/regerror.c: Enable building Tcl with Microsoft's latest
* generic/tcl.h: compiler offering (VS2005). We have to handle
* generic/tclDate.c: a number of oddities as they have deprecated
* tests/env.test: most of the standard C library and now
* win/makefile.vc: generate manifest files to be linked into the
* win/nmakehlp.c: binaries. [Bug 1424909]
* win/rules.vc:
* win/tclWinTime.c:
2006-06-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tclLoadDl.c (TclpDlopen): Workaround for a compiler bug in Sun
Forte 6. [Bug 1503729]
2006-06-06 Don Porter <dgp@users.sourceforge.net>
* doc/GetStdChan.3: Added recommendation that each call to
Tcl_SetStdChannel() be accompanied by a call to Tcl_RegisterChannel().
2006-05-31 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclNamesp.c (NamespaceInscopeCmd): revert [Bug 1400572]
fix of 2006-01-09 for [namespace inscope] as it seems to mess with
itcl scope decoding. Leaving namespace-29.6 test failure until final
cause it determined.
2006-05-29 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tcl.h (Tcl_DecrRefCount): use if/else construct to allow
placement in unbraced outer if/else conditions. (jcw)
2006-05-27 Daniel Steffen <das@users.sourceforge.net>
* macosx/tclMacOSXNotify.c: implemented pthread_atfork() handler that
* unix/tcl.m4 (Darwin): recreates CoreFoundation state and notifier
thread in the child after a fork(). Note that pthread_atfork() is
available starting with Tiger only. Because vfork() is used by the core
on Darwin, [exec]/[open] are not affected by this fix, only extensions
or embedders that call fork() directly (such as TclX). However, this
only makes fork() safe from corefoundation tcl with --disable-threads;
as on all platforms, forked children may deadlock in threaded tcl due
to the potential for stale locked mutexes in the child. [Patch 923072]
* unix/configure: autoconf-2.59
2006-05-24 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
* unix/tcl.m4 (SC_CONFIG_SYSTEM): Fixed quoting of command script to
awk; it was a rarely used branch, but it was wrong. [Bug 1494160]
2006-05-13 Don Porter <dgp@users.sourceforge.net>
* generic/tclFileName.c (TclDoGlob): Disabled the partial
normalization done by the recursive glob routine, since changing the
precise string of the pathname broke [glob] on some Tcl_Filesystems.
[Bug 943995]
* generic/tclProc.c (ProcCompileProc): When a bump of the compile
epoch forces the re-compile of a proc body, take care not to
overwrite any Proc struct that may be referred to on the active
call stack. This fixes [Bug 1482718]. Note that the fix will not be
effective for code that calls the private routine TclProcCompileProc()
directly.
2006-05-05 Don Porter <dgp@users.sourceforge.net>
* generic/tclMain.c (Tcl_Main): Corrected flaw that required
* tests/main.test: (Tcl_Main-4.5): processing of one interactive
command before passing control to the loop routine registered with
Tcl_SetMainLoop() [Bug 1481986]
2006-05-04 Don Porter <dgp@users.sourceforge.net>
* README: Bump version number to 8.4.14
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure.in:
* unix/configure: autoconf-2.13
* win/configure:
* generic/tclExecute.c (ExprSrandFunc): Restore acceptance of wide
* tests/expr-old.test: integer values by srand() [Bug 1480509]
2006-04-12 Don Porter <dgp@users.sourceforge.net>
*** 8.4.13 TAGGED FOR RELEASE ***
* changes: updates for another RC.
2006-04-11 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdMZ.c: Stop some interference between enter traces
* tests/trace.test: and enterstep traces. [Bug 1458266]
2006-04-10 Don Porter <dgp@users.sourceforge.net>
* changes: updates for another RC.
2006-04-06 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclRegexp.c (FinalizeRegexp): full reset data to indicate
readiness for reinitialization.
2006-04-06 Don Porter <dgp@users.sourceforge.net>
* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): It seems there
* tests/indexObj.test: are extensions that rely on the prior behavior
* doc/GetIndex.3: that the empty string cannot succeed as a
unique prefix matcher, so I'm restoring Donal Fellows's solution.
Added mention of this detail to the documentation. [Bug 1464039]
2006-04-06 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4: removed TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
define on Darwin. [Bug 1457515]
* unix/configure: autoconf-2.13
2006-04-05 Don Porter <dgp@users.sourceforge.net>
* library/reg/pkgIndex.tcl: Long overlooked bump to registry
* win/tclWinReg.c: package version 1.1.4 (should have
been done for the Tcl 8.4.8 release!)
* library/dde/pkgIndex.tcl: Long overlooked bump to dde package
* win/tclWinDde.c: version 1.2.4 (should have been done
for the Tcl 8.4.8 release!)
2006-04-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): Allow empty
strings to be matched by the Tcl_GetIndexFromObj machinery, in the
same manner as any other key. [Bug 1464039]
2006-04-04 Don Porter <dgp@users.sourceforge.net>
* generic/tclPkg.c: Revised Bug 1162286 fix from 2005-11-08 to be
* tests/pkg.test: even more forgiving of package version
mismatch errors in [package ifneeded] commands, not even logging any
warning messages. This further reduces the
***POTENTIAL INCOMPATIBILITY*** noted for that change.
2006-04-03 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.c (ReadChars): Added check, panic and commentary to a
piece of code which relies on BUFFER_PADDING to create enough space at
the beginning of each buffer for the insertion of partial multibyte
data at the beginning of a buffer. Commentary explains why this code
is OK, and the panic is as a precaution if someone twiddled the
BUFFER_PADDING into uselessness.
* generic/tclIO.c (ReadChars): Temporarily suppress the use of
TCL_ENCODING_END set when EOF was reached while the buffer we are
converting is not truly the last buffer in the queue. Together with
the Utf bug below it was possible to completely wreck the buffer data
structures, eventually crashing Tcl. [Bug 1462248]
* generic/tclEncoding.c (UtfToUtfProc): Stop accessing memory beyond
the end of the input buffer when TCL_ENCODING_END is set and the last
bytes of the buffer start a multi-byte sequence. This bug contributed
to [Bug 1462248].
2006-03-28 Jeff Hobbs <jeffh@ActiveState.com>
* win/configure, win/tcl.m4: define MACHINE for gcc builds as well.
Needed by Tk for manifest generation.
* win/tclWinConsole.c: revert 2005-11-03 [Patch 1256872] change to add
win32 unicode console support as it broke the ability to modify the
encoding to the console.
2006-03-28 Daniel Steffen <das@users.sourceforge.net>
* unix/tclUnixFCmd.c (TclpObjNormalizePath): deal with *BSD/Darwin
realpath() converting relative paths into absolute paths. [Bug 1064247]
2006-03-28 Vince Darley <vincentdarley@sourceforge.net>
* generic/tclIOUtil.c: fix to nativeFilesystemRecord comparisons
(lesser part of [Bug 1064247])
2006-03-27 Pat Thoyts <patthoyts@users.sourceforge.net>
* win/tclWinTest.c: Fixes for [Bug 1456373] (mingw-gcc issue)
2006-03-23 Don Porter <dgp@users.sourceforge.net>
* tests/expr.test: Nan self-inquality test silenced. [Bug 761471]
2006-03-22 Don Porter <dgp@users.sourceforge.net>
* changes: updates for another RC.
2006-03-18 Vince Darley <vincentdarley@sourceforge.net>
* generic/tclTest.c:
* win/tclWinFile.c:
* win/tclWinTest.c:
* tests/fCmd.test:
* tests/winFCmd.test:
* tests/tcltest.test: Backport of [file writable] fixes for Windows
from HEAD. [Bug 1193497]
2006-03-16 Andreas Kupries <andreask@activestate.com>
* doc/open.n: Documented the changed behaviour of 'a'ppend mode.
* tests/io.test (io-43.1 io-44.[1234]): Rewritten to be
self-contained with regard to setup and cleanup. [Bug 681793]
* generic/tclIOUtil.c (TclGetOpenMode): Added the flag O_APPEND to the
list of POSIX modes used when opening a file for 'a'ppend. This
enables the proper automatic seek-to-end-on-write by the OS. See [Bug
680143] for longer discussion.
* tests/ioCmd.test (iocmd-13.7.*): Extended the testsuite to check the
new handling of 'a'.
2006-03-15 Andreas Kupries <andreask@activestate.com>
* tests/socket.test: Extended the timeout in socket-11.11 from 10 to
40 seconds to allow for really slow machines. Also extended
actual/expected results with value of variable 'done' to make it
clearer when a test fails due to a timeout. [Bug 792159]
2006-03-14 Andreas Kupries <andreask@activestate.com>
* generic/tclPipe.c (TclCreatePipeline): Modified the processing of
pipebars to fail if the last bar is followed only by redirections.
[Bug 768659]
2006-03-14 Andreas Kupries <andreask@activestate.com>
* doc/fconfigure.n: Clarified that -translation is binary is reported
as lf when queried, because it is identical to lf, except for the
special additional behaviour when setting it. [Bug 666770]
2006-03-14 Andreas Kupries <andreask@activestate.com>
* win/tclWinPipe.c (Tcl_WaitPid): Backport of fix made to the head by
David Gravereaux in 2004. See ChangeLog entry 2004-01-19. [Bug 1381436]
Fixed a thread-safety problem with the process list. The delayed cut
operation after the wait was going stale by being outside the list
lock. It now cuts within the lock and does a locked splice for when it
needs to instead. [Bug 859820]
2006-03-13 Don Porter <dgp@users.sourceforge.net>
* generic/tclEncoding.c: Report error when an escape encoding
is missing one of its sub-encodings [Bug 506653]
* unix/configure.in: Revert change from 2005-07-26 that sometimes
* unix/configure: added $prefix/share to the tcl_pkgPath.
See [Patch 1231015]. autoconf-2.13.
2006-03-10 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
-- Summary of changes fixing [Bug 1437595] --
* generic/tclEvent.c: Cosmetic touches and identation
* generic/tclInt.h: Added TclpFinalizeSockets() call.
* generic/tclIO.c: Calls TclpFinalizeSockets() as part of the
TclFinalizeIOSubsystem().
* unix/tclUnixSock: Added no-op TclpFinalizeSockets().
* mac/tclMacSock.c:
* win/tclWinPipe.c
* win/tclWinSock.c: Finalization of the sockets/pipes is now solely
done in TclpFinalizeSockets() and TclpFinalizePipes() and not over the
thread-exit handler, because the order of actions the Tcl generic core
will impose may result in cores/hangs if the thread exit handler tears
down corresponding subsystem(s) too early.
2006-03-10 Vince Darley <vincentdarley@sourceforge.net>
* win/tclWin32Dll.c:
* win/tclWinInt.h:
* win/tclWinFile.c: backported some fixes from HEAD relating to 'file
readable' and 'file writable', but main 'file writable' bug still
outstanding.
2006-03-07 Don Porter <dgp@users.sourceforge.net>
* README: Bump version number to 8.4.13 and update
* changes: changes to start prep for an 8.4.13 release.
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure{.in}:
* unix/tcl.spec:
* win/README.binary:
* win/configure{.in}:
* tests/parse.test: Missing constraint
2006-03-06 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c: Revised handling of TCL_EVAL_* flags to
* tests/parse.test: simplify TclEvalObjvInternal and to correct
the auto-loading of alias targets (parse-8.12). [Bug 1444291]
2006-03-02 Jeff Hobbs <jeffh@ActiveState.com>
* win/Makefile.in: convert _NATIVE paths to use / to avoid ".\"
path-as-escape issue.
* unix/tcl.m4, win/tcl.m4: []-quote ac_defun functions.
2006-03-02 Pat Thoyts <patthoyts@users.sourceforge.net>
* unix/tcl.m4: Fix for [Tk Bug 1334613] to sort out shared library
* unix/configure: issues on NetBSD. Regenerated configure script.
2006-02-28 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c: Corrections to be sure that TCL_EVAL_GLOBAL
* tests/parse.test: evaluations act the same as [uplevel #0]
* tests/trace.test: evaluations, even when execution traces or
invocations of [::unknown] are present. [Bug 1439836]
2006-02-16 Don Porter <dgp@users.sourceforge.net>
* generic/tclIndexObj.c: Disallow the "ambiguous" error message
* tests/indexObj.test: when TCL_EXACT matching is requested.
2006-02-15 Don Porter <dgp@users.sourceforge.net>
* generic/tclIO.c: Made several routines tolerant of
* generic/tclIOUtil.c: interp == NULL arguments. [Bug 1380662]
2006-02-09 Don Porter <dgp@users.sourceforge.net>
* tests/main.test (Tcl_Main-6.7): Improved robustness of command
auto-completion test. [Bug 1422736]
2006-01-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tclUnixInit.c (TclpInitPlatform): Improved conditions on when
to update the FP rounding mode on FreeBSD, taken from FreeBSD port.
2006-01-23 Miguel Sofer <msofer@users.sf.net>
* generic/tclStringObj.c (Tcl_GetRange):
* tests/stringTest (string-12.21):fixed incorrect handling of internal
rep in Tcl_GetRange. Thanks to twylite and Peter Spjuth. [Bug 1410553]
2006-01-16 Reinhard Max <max@suse.de>
* generic/tclPipe.c (FileForRedirect): Prevent nameString from being
freed without having been initialized.
* tests/exec.test: Added a test for the above.
2006-01-12 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* generic/tclIOUtil.c (Tcl_FSGetInternalRep): fixed potential
overwriting of already freed memory which caused all kinds of (rare
but reproducible) coredumps all over the place.
2006-01-11 Don Porter <dgp@users.sourceforge.net>
* tests/error.test (error-7.0): Test the timing of write traces on
::errorInfo. [Bug 1397843]
2006-01-10 Daniel Steffen <das@users.sourceforge.net>
* unix/configure: add caching, use AC_CACHE_CHECK instead of
* unix/configure.in: AC_CACHE_VAL where possible, consistent message
* unix/tcl.m4: quoting, sync relevant tclconfig/tcl.m4 and HEAD
changes and gratuitous formatting differences, fix SC_CONFIG_MANPAGES
with default argument, Darwin improvements to SC_LOAD_*CONFIG.
2006-01-09 Don Porter <dgp@users.sourceforge.net>
* generic/tclNamesp.c (NamespaceInscopeCmd): [namespace inscope]
* tests/namespace.test: commands were not reported by [info level].
[Bug 1400572]
2005-12-20 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclThreadAlloc.c (Tcl_GetMemoryInfo): Format values as longs
and not ints, so they are less likely to wrap on 64-bit machines.
2005-12-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/Tcl.n: Clarify what is going on in variable substitution
following thread on comp.lang.tcl.
2005-12-14 Daniel Steffen <das@users.sourceforge.net>
* generic/tclIOUtil.c: workaround gcc warning "comparison is always
* generic/tclTest.c: false due to limited range of data type".
* unix/configure.in: run check for fts API on all platforms, since
Linux glibc2 and *BSDs also have this and using fts is more efficient
than recursive opendir/readdir (sync with HEAD).
* unix/configure: regen.
2005-12-12 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tcl.m4, unix/configure: Fix sh quoting error reported in
bash-3.1+ [Bug 1377619] (schafer)
2005-12-12 Reinhard Max <max@suse.de>
* generic/tclExecute.c (ExprAbsFunc): fixed the abs(MIN_INT) case so
that it doesn't break on compilers that don't assume integers to wrap
around (e.g. gcc-4.1.0).
2005-12-09 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
* tests/lsearch.test (lsearch-10.8..10): If the -start is off the end,
* generic/tclCmdIL.c (Tcl_LsearchObjCmd): searching should find
nothing at all. [Bug 1374778]
2005-12-05 Daniel Steffen <das@users.sourceforge.net>
*** 8.4.12 TAGGED FOR RELEASE ***
* unix/tclUnixPort.h (Darwin): fix incorrect __DARWIN_UNIX03 configure
overrides that were originally copied from Darwin CVS (rdar://3693001).
2005-12-05 Don Porter <dgp@users.sourceforge.net>
* unix/configure.in: Revised fix for [Bug 1034337] from Daniel
* unix/tclUnixFCmd.c: Steffen. Uses fts_*() routines.
* unix/configure: autoconf-2.13
* changes: Update changes for 8.4.12 release
2005-12-04 Daniel Steffen <das@users.sourceforge.net>
* README: refer to macosx/README instead of mac/README.
* mac/README: add note that mac classic port is no longer supported.
2005-12-03 Jeff Hobbs <jeffh@ActiveState.com>
* README: correct 2 urls
2005-12-01 Don Porter <dgp@users.sourceforge.net>
* changes: Update changes for 8.4.12 release
2005-12-01 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4 (Darwin): fixed error when MACOSX_DEPLOYMENT_TARGET unset
* unix/configure: regen.
2005-11-29 Jeff Hobbs <jeffh@ActiveState.com>
* win/tcl.m4: Add build support for Windows-x64 builds.
* win/configure: --enable-64bit now accepts =amd64|ia64 for
* win/Makefile.in: Windows 64-bit build variants (default: amd64)
* win/makefile.vc: [Bug 1369597]
2005-11-29 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclObj.c (Tcl_GetWideIntFromObj): Add more efficient
conversion to wides from normal ints. [Bug 1310081]
* generic/tclCmdIL.c (Tcl_LsearchObjCmd): Allow [lsearch -regexp] to
process REs that contain backreferences. This expensive mode of
operation is only used if the RE would otherwise cause a compilation
failure. [Bug 1366683]
2005-11-28 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* win/tclWinSock.c (CreateSocket): Applied [Patch 1353853] to prevent
reads of uninitialized variables during cleanup.
2005-11-27 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4 (Darwin): add 64bit support, check for Tiger copyfile(),
add CFLAGS to SHLIB_LD to support passing -isysroot in env(CFLAGS) to
configure (flag can't be present twice, so can't be in both CFLAGS and
LDFLAGS during configure), don't use -prebind when deploying on 10.4,
define TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING (rdar://3171542).
(SC_ENABLE_LANGINFO, SC_TIME_HANDLER): add/fix caching, fix obsolete
autoconf macros. Sync with tk/unix/tcl.m4, sync whitespace with HEAD.
* unix/configure.in: fix obsolete autoconf macros, sync gratuitous
formatting/ordering differences with tk/unix/configure.in.
* unix/Makefile.in: add CFLAGS to tclsh/tcltest link to make
executable linking the same as during configure (needed to avoid
loosing any linker relevant flags in CFLAGS, in particular flags that
can't be in LDFLAGS). Avoid concurrent linking of tclsh and compiling
of tclTestInit.o or xtTestInit.o during parallel make.
(checkstubs, checkdoc, checkexports): dependency and Darwin fixes
* unix/tclLoadDyld.c (TclpDlopen): [Bug 1204237] use
NSADDIMAGE_OPTION_WITH_SEARCHING on second NSAddImage only.
(TclGuessPackageName): should not be MODULE_SCOPE.
(TclpLoadMemory): ppc64 and endian (i386) fixes, add support for
loading universal (fat) bundles from memory.
* unix/tclUnixPort.h:
* unix/tclUnixFCmd.c: add support for new Tiger copyfile() API to
enable copying of xattrs & ACLs by [file copy].
* generic/tcl.h: add Darwin specifc configure overrides for TCL_WIDE
defines to support fat compiles of ppc and ppc64 at the same time,
(replaces Darwin CVS fix by emoy, rdar://3693001).
add/correct location of version numbers in macosx files.
* generic/tclInt.h: clarify fat compile comment.
* unix/tclUnixPort.h: add Darwin specifc configure overrides to
support fat compiles, where configure runs only once for multiple
architectures (replaces Darwin CVS fix by emoy, rdar://3693001).
* macosx/tclMacOSXBundle.c:
* macosx/tclMacOSXNotify.c:
* unix/tclUnixNotfy.c: fix #include order to support compile time
* unix/tclUnixPort.h: override of HAVE_COREFOUNDATION in
tclUnixPort.h when building for ppc64
* macosx/Tcl.pbproj/default.pbxuser (new file):
* macosx/Tcl.pbproj/jingham.pbxuser:
* macosx/Tcl.pbproj/project.pbxproj: sync with HEAD.
* macosx/README: clarification/cleanup, sync with HEAD, document
universal (fat) builds via CFLAGS (i.e. all of ppc ppc64 i386 at once).
* macosx/Makefile: add support for reusing configure cache, build
target fixes, remove GENERIC_FLAGS override now handled by tcl.m4.
* generic/tclIOUtil.c:
* generic/tclRegexp.c:
* generic/tclVar.c: declare globals used only in own file as static
(sync with HEAD).
* generic/rege_dfa.c (getvacant):
* generic/regexec.c (cfind):
* generic/tclCompExpr.c (CompileSubExpr):
* unix/tclUnixChan.c (TclUnixWaitForFile): initialise variables to
silence gcc 4 warnings.
* generic/regguts.h: only #define NDEBUG if not already #defined.
* macosx/tclMacOSXNotify.c: sync whitespace & comments with HEAD
* unix/configure: regen.
2005-11-20 Joe English <jenglish@users.sourceforge.net>
* generic/tclStubLib.c: Don't set tclStubsPtr to 0 when
Tcl_PkgRequireEx() fails [Fix for [Bug 1091431] "Tcl_InitStubs failure
crashes wish"]
2005-11-18 Miguel Sofer <msofer@users.sf.net>
* tests/trace.test (trace-34.5): [Bug 1047286], added a second test
illustrating the role of "ns in callStack" in the ns's visibility
during deletion traces.
* generic/tclBasic.c (Tcl_DeleteCommandFromToken):
* generic/tclCmdMZ.c (TraceCommandProc):
* generic/tclInt.h (NS_KILLED):
* generic/tclNamesp.c (Tcl_DeleteNamespace
* tests/namespace.test (namespace-7.3-6):
* tests/trace.test (trace-20.13-16): fix [Bugs 1355942/1355342].
2005-11-18 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIO.c (TclFinalizeIOSubsystem): preserve statePtr until we
netrieve next statePtr from it.
2005-11-18 Don Porter <dgp@users.sourceforge.net>
* generic/tclPkg.c: Revised Bug 1162286 fix from 2005-11-08 to be
* tests/pkg.test: more forgiving of package version mismatch
errors in [package ifneeded] commands. This reduces the
***POTENTIAL INCOMPATIBILITY*** noted for that change.
2005-11-18 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.c (TclFinalizeIOSubsystem): Applied Pat Thoyts' patch
for [Bug 1359094]. This moves the retrieval of the next channel state
to the end of the loop, as the called closeproc may close other
channels, i.e., modify the list we are iterating, invalidating any
pointer retrieved earlier.
2005-11-18 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
* library/http/http.tcl (http::geturl): Improved syntactic validation
of URLs, and better error messages in some cases. [Bug 1358369]
2005-11-16 Don Porter <dgp@users.sourceforge.net>
* README: Bump version number to 8.4.12
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure.in:
* unix/configure: autoconf-2.13
* win/configure:
2005-11-15 Don Porter <dgp@users.sourceforge.net>
* changes: Update changes for 8.4.12 release
2005-11-15 Kevin B. Kenny <kennykb@acm.org>
* tests/cmdAH.test: Backported the fix for [Bug 926016] because of
* win/tclWinFile.c: a repeated bug report in 8.4 [Bug 1353840].
Windows [file mtime] will now return seconds from the Posix epoch
correctly (except for FAT32 file systems after a DST change without a
reboot - for which there is no help). A side effect is that file times
will appear different in Tcl from the way they do in Windows Explorer
or a 'dir' listing, because the Microsoft tools get the DST state
wrong in the listings.
2005-11-09 Kevin B. Kenny <kennykb@acm.org>
* generic/tclTimer.c: Changed [after] so that it behaves correctly
* tests/timer.test: with negative arguments. [Bug 1350293]
2005-11-08 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixFCmd.c (MAX_READDIR_UNLINK_THRESHOLD): reduce to 130
based on errors seen on OS X 10.3 with lots of links in a dir. [Bug
1034337 followup]
2005-11-08 Don Porter <dgp@users.sourceforge.net>
* tests/expr.test: Portable tests expr-46.13-18 [Bug 1341368]
* generic/tclPkg.c: Corrected inconsistencies in the value returned
* tests/pkg.test: by Tcl_PkgRequire(Ex) so that the returned
values will always agree with what is stored in the package database.
This way repeated calls to Tcl_PkgRequire(Ex) have the same results.
Thanks to Hemang Lavana. [Bug 1162286]
***POTENTIAL INCOMPATIBILITY***: Incompatible with those existing
packages that are accustomed to the [package] command forgiving
their bugs.
* tests/namespace.test (25.7,8): Backport test of knownBug.
2005-11-08 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclCmdMZ.c (TclTraceVariableObjCmd, TraceVarProc): Applied
Miguel's fix for [Bug 1348775]. It is not quite as elegant as the one
applied to the HEAD, but it is easier to use it rather than fully
backporting.
2005-11-07 Miguel Sofer <msofer@users.sf.net>
* tests/trace.test (trace-13.2-4): added tests to detect leak, see
[Bug 1348775].
2005-11-04 Don Porter <dgp@users.sourceforge.net>
* unix/tcl.m4: Added code to enable [load] on LynxOS. Thanks to
heidibr@users.sf.net for the patch. [Bug 1163896]
* unix/configure: autoconf-2.13.
2005-11-04 Pat Thoyts <patthoyts@users.sourceforge.net>
* win/tclWinPipe.c: Applied [Patch 1267871] by Matt Newman which
* win/tclWinPort.h: provides extended error code support.
* tests/exec.test: Wrote some tests for this feature.
2005-11-04 Kevin Kenny <kennykb@acm.org>
* generic/tclGetDate.y: Added abbreviations for the Korean timezone.
* generic/tclDate.c: Regenerated.
* compat/strftime.c: Fixed a problem where the name of the time zone
was double-converted from system encoding to UTF-8. Thanks to the
anonymous submitter of [Bug 1317477] for the report and the patch.
2005-11-04 Miguel Sofer <msofer@users.sf.net>
* generic/tclInt.h:
* generic/tclNamesp.c:
* generic/tclVar.c: fix for [Bugs 1338280/1337229]. Thanks Don.
* tests/trace.test: fix duplicate test numbers
2005-11-03 Don Porter <dgp@users.sourceforge.net>
* generic/tclUnixInit.c (TclpSetInitialEncodings): Modified so
that multiple calls can continue to atttempt to properly set the
system encoding. Needed for Tclkit to properly support non-default
encodings. Thanks to Yaroslav Schekin. [Bug 1201171]
2005-11-03 Pat Thoyts <patthoyts@users.sourceforge.net>
* win/tclWin32Dll.c: Backported Anton Kovalenko's [Patch 1256872]
* win/tclWinConsole.c: to give unicode console support on
* win/tclWinInt.h: suitable systems (eg: NT/XP)
2005-11-01 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdMZ.c (TclCheckExecutionTraces): Corrected mistaken
assumption that all command traces are set at the script level.
Report/fix from Jacques H. de Villiers. [Bug 1337941]
* tests/expr-old.test (expr-32.52): Use int(.) to restrict result
of left shift to the C long range.
2005-10-29 Mo DeJong <mdejong@users.sourceforge.net>
* tests/expr.test: Fix problems in new round() tests that lead to
correct result only on 32 bit long systems. [Bug 1341368]
2005-10-29 Miguel Sofer <msofer@users.sf.net>
* generic/tclCmdMZ.c (TraceVarProc): [Bug 1337229], partial fix.
Ensure that a second call with TCL_TRACE_DESTROYED does not lead to a
second call to Tcl_EventuallyFree(). It is still true that that second
call should not happen, so the bug is not completely fixed.
* tests/trace.test (test-18.3-4): added tests for [Bugs 1337229 and
1338280].
2005-10-27 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tclExecute.c (ExprRoundFunc): Fix typo where number before
rounding is compared with smallest integer instead of number after
rounding. This fix does not change the results of any tests.
* tests/expr.test: Add round() tests for cases near the min and max
int values.
* tests/util.test: Remove pointless warning code about testobj command
2005-10-23 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c:
* generic/tclBinary.c:
* generic/tclCmdAH.c:
* generic/tclCmdIL.c:
* generic/tclCmdMZ.c:
* generic/tclExecute.c:
* generic/tclLink.c:
* generic/tclMain.c:
* generic/tclProc.c:
* generic/tclScan.c:
* generic/tclTest.c:
* generic/tclVar.c:
* mac/tclMacInit.c:
* unix/tclUnixInit.c:
* win/tclWinInit.c: Ensure that the core never calls TclPtrSetVar,
Tcl_SetVar2Ex, Tcl_ObjSetVar2 or Tcl_SetObjErrorCode with a 0-ref new
value. It is not possible to handle error returns correctly in that
case [Bug 1334947], one has the choice of leaking the object in some
cases, or else risk crashing in some others.
2005-10-22 Miguel Sofer <msofer@users.sf.net>
* generic/tclExecute.c (INST_CONCAT): disable the optimisation for
wide integers. [Bug 1251791]
2005-10-14 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* generic/tclIO.c (Tcl_ClearChannelHandlers): removed change dated
2005-10-04 below. Look into [Bug 1323992] for detailed discussion.
2005-10-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclCmdAH.c (Tcl_FormatObjCmd): Stop [format] from seeing
the difference between ints and wides. [Bug 1284178]
2005-10-13 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* generic/tclIO.c (Tcl_ClearChannelHandlers): temporary
ifdef TCL_THREADS changes done to de-activate pending
event processing when channel is being closed/cutted.
2005-10-10 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclInt.h: ensure MODULE_SCOPE decl
2005-10-07 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixFCmd.c (TraverseUnixTree): Adjust 2004-11-11 change to
* tests/fCmd.test (fCmd-20.2): account for NFS special
files with a readdir rewind threshold. [Bug 1034337]
2005-10-05 Andreas Kupries <andreask@activestate.com>
* generic/tclPipe.c (TclCreatePipeline): Fixed [Bug 1109294]. Applied
the patch provided by David Gravereaux.
* doc/CrtChannel.3: Fixed [Bug 1104682], by application of David
Welton's patch for it, and added a note about wideSeekProc.
2005-10-05 Jeff Hobbs <jeffh@ActiveState.com>
* tests/env.test (env-6.1):
* win/tclWinPort.h: define USE_PUTENV_FOR_UNSET 1
* generic/tclEnv.c (TclSetEnv, TclUnsetEnv): add
USE_PUTENV_FOR_UNSET to existing USE_PUTENV define to account for
various systems that have putenv(), but can't unset env vars with it.
Note difference between Windows and Linux for actually unsetting the
env var (use of '=').
Correct the resizing of the environ array. We assume that we are in
full ownership, but that's not correct. [Bug 979640]
2005-10-04 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinSerial.c (SerialSetOptionProc): free argv [Bug 1067708]
* tests/http.test: Do not URI encode -._~ according to
* library/http/http.tcl (init): RFC3986. [Bug 1182373] (aho)
* generic/tclIOUtil.c (TclFSNormalizeAbsolutePath): make static
* generic/tclEncoding.c (TclFindEncodings): make static
* unix/tclLoadShl.c (TclpDlopen): use DYNAMIC_PATH on second
shl_load only. [Bug 1204237]
2005-10-04 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* generic/tclIO.c (Tcl_ClearChannelHandlers): now deletes any
outstanding timer for the channel. Also, prevents events still
in the event queue from triggering on the current channel.
* generic/tclTimer.c (Tcl_DeleteTimerHandler): bail out early
if passed NULL argument.
2005-09-30 Don Porter <dgp@users.sourceforge.net>
* generic/tclMain.c: Separate encoding conversion of command line
arguments from list formatting. [Bug 1306162]
2005-09-27 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclBinary.c (FormatNumber): Factorize out copying of double
values to a helper to work around ugly broken compiler problems. [Bug
1116542]
2005-09-15 Miguel Sofer <msofer@users.sf.net>
* doc/ParseCmd.3: copy/paste fix [Bug 1292427]
2005-09-15 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tcl.m4 (SC_TCL_EARLY_FLAGS): Added extra hack to allow Tcl to
transparently open large files on RHEL 3. [Bug 1287638]
* unix/configure: autoconf-2.13
2005-09-07 Don Porter <dgp@users.sourceforge.net>
* generic/tclUtf.c (Tcl_UniCharToUtf): Corrected handling of negative
* tests/utf.test (utf-1.5): Tcl_UniChar input value. Incorrect
handling was producing byte sequences outside of Tcl's legal internal
encoding. [Bug 1283976]
2005-08-29 Kevin Kenny <kennykb@acm.org>
* generic/tclBasic.c (ExprMathFunc): Restored "round away from zero"
* tests/expr.test (expr-46.*): behaviour to the "round"
function. Added test cases for the behavior, including the awkward
case of a number whose fractional part is 1/2-1/2ulp. [Bug 1275043]
2005-08-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclListObj.c (UpdateStringOfList): Stop uncontrolled and
unsafe crashes from happening when working with very large string
representations. [Bug 1267380]
2005-08-17 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclFCmd.c (TclFileMakeDirsCmd): fix to race condition in
file mkdir (backport from head 2005-06-13) [Bug 1217375]
2005-08-16 Kevin Kenny <kennykb@acm.org>
* generic/tclEvent.c (Tcl_Finalize): Pushed Tcl_FinalizeLoad and
Tcl_ResetFilesystem down after Tcl_FinalizeThreadAlloc because
unloading DLLs can't happen while they still own TSD keys.
(This is a backport of changes made in the HEAD on 2005-08-10.)
2005-08-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tclUnixInit.c (localeTable): Solaris uses a non-standard name
for the cp1251 charset. Thanks to Victor Wagner for reporting this.
[Bug 1252475]
2005-08-05 Kevin Kenny <kennykb@users.sourceforge.net>
* generic/tclExecute.c (TclExecuteByteCode): Fixed a corner case
* tests/expr.test (expr-38.1): where applying abs to
MIN_INT failed to promote the result to a wide integer. [Bug 1241572]
2005-08-04 Don Porter <dgp@users.sourceforge.net>
* generic/tclObj.c: Simplified routines that manage the typeTable.
2005-08-03 Don Porter <dgp@users.sourceforge.net>
* generic/tclCompExpr.c: Untangled some dependencies in the
* generic/tclEvent.c: order of finalization routines.
* generic/tclInt.h: [Bug 1251399]
* generic/tclObj.c:
2005-07-30 Daniel Steffen <das@users.sourceforge.net>
* unix/configure, unix/tcl.m4: revert 2005-07-28 change.
* unix/tclLoadDyld.c (TclpDlopen, TclpLoadMemory): workarounds for
bugs/changes in behaviour in Mac OS X 10.4 Tiger, sync formatting
changes from HEAD.
2005-07-29 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCmdIL.c (InfoGlobalsCmd): Even in high-speed mode, still
have to take care with non-existant variables. [Bug 1247135]
2005-07-28 Mo DeJong <mdejong@users.sourceforge.net>
* win/README: Update link to msys_mingw8.zip. Remove old Cygwin +
Mingw info, people should just build with the msys + mingw
configuration.
2005-07-28 Jeff Hobbs <jeffh@ActiveState.com>
* unix/configure, unix/tcl.m4: defined TCL_LOAD_FROM_MEMORY on Darwin
only for SHARED_BUILD
2005-07-28 Donal K. Fellows <dkf@users.sf.net>
* generic/tclPipe.c (TclCreatePipeline): Arrange for POSIX systems to
* unix/tclUnixPipe.c (TclpOpenFile): use the O_APPEND flag for
* tests/exec.test (exec-19.1): files opened in a pipeline
like ">>this". Note that Windows cannot support such access; there is
no equivalent flag on the handle that can be set at the kernel-call
level. The test is unix-specific in every way. [Bug 1245953]
2005-07-26 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/configure.in: Check for a $prefix/share directory and add it
the the package if found. This will check for Tcl packages in
/usr/local/share when Tcl is configured with the default dist install.
[Patch 1231015]
2005-07-26 Don Porter <dgp@users.sourceforge.net>
* doc/tclvars.n: Improved $errorCode documentation. [RFE 776921]
* generic/tclBasic.c (Tcl_CallWhenDeleted): Converted to use
per-thread counter, rather than a process global one that required
mutex protection. [RFE 1077194]
* generic/tclNamesp.c (TclTeardownNamespace): Re-ordering so that
* tests/trace.test (trace-34.4): command delete traces fire
while the command still exists. [Bug 1047286]
2005-07-24 Mo DeJong <mdejong@users.sourceforge.net>
* unix/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH):
* win/tcl.m4 (SC_PROG_TCLSH, SC_BUILD_TCLSH):
Split confused search for tclsh on PATH and build and install
locations into two macros. SC_PROG_TCLSH searches just the PATH.
SC_BUILD_TCLSH determines the name of the tclsh executable in the Tcl
build directory. [Bug 1160114], [Patch 1244153]
2005-07-22 Don Porter <dgp@users.sourceforge.net>
* library/auto.tcl: Updates to the Tcl script library to make
* library/history.tcl: use of Tcl 8.4 feautures. Thanks to
* library/init.tcl: Patrick Fradin for prompting on this.
* library/package.tcl: [Patch 1237755]
* library/safe.tcl:
* library/word.tcl:
2005-07-07 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tcl.m4, unix/configure: Backported [Bug 1095909], removing
* unix/tclUnixPort.h: any use of readdir_r as it is not
* unix/tclUnixThrd.c: necessary and just confuses things.
2005-07-05 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdAH.c: New "encoding" Tcl_ObjType (not registered)
* generic/tclEncoding.c: that permits longer lifetimes of the
* generic/tclInt.h: Tcl_Encoding values kept as intreps of
Tcl_Obj's. Reduces the need for repeated reading of encoding
definition files from the filesystem. [Bug 1077262]
* generic/tclNamesp.c: Allow for [namespace import] of a command
* tests/namespace.test: over a previous [namespace import] of itself
without throwing an error. [RFE 1230597]
2005-07-01 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* unix/tclUnixNotfy.c: protect against spurious wake-ups while waiting
on the condition variable when tearing down the notifier thread. [Bug
1222872]
2005-06-27 Don Porter <dgp@users.sourceforge.net>
*** 8.4.11 TAGGED FOR RELEASE ***
* library/auto.tcl: Reverted to Revision 1.12.2.3 (Tcl 8.4.9).
Restores the (buggy) behavior of [auto_reset] that fails to clear
away auto-loaded commands from non-global namespaces. Fixing this
bug exposed an unknown number of buggy files out there (including at
least portions of the Tk script library) that cannot tolerate double
[source]-ing. The burden of fixing these exposed bugs will not be
forced on package/extension/application authors until Tcl 8.5.
2005-06-24 Kevin Kenny <kennykb@acm.org>
* generic/tclEvent.c (Tcl_Finalize):
* generic/tclInt.h:
* generic/tclPreserve.c (TclFinalizePreserve): Changed the
finalization logic so that Tcl_Preserve finalizes after exit
handlers run; a lot of code called from Tk's exit handlers
presumes tha Tcl_Preserve will still work even from an exit
handler. Also, made the assertion check that no exit handlers
are created in Tcl_Finalize conditional on TCL_MEM_DEBUG to
avoid spurious panics in the "stable" release.
2005-06-24 Don Porter <dgp@users.sourceforge.net>
* library/auto.tcl: Make file safe to re-[source] without
destroying registered auto_mkindex_parser hooks.
2005-06-23 Daniel Steffen <das@users.sourceforge.net>
* tools/tcltk-man2html.tcl: fixed useversion glob pattern to accept
multi-digit patchlevels.
2005-06-23 Kevin Kenny <kennykb@acm.org>
* win/tclWinChan.c: More rewriting of __asm__ blocks that
* win/tclWinFCmd.c: implement SEH in GCC, because mingw's
gcc 3.4.2 is not as forgiving of violations committed by
the old code and caused panics. [Bug 1225957]
2005-06-23 Daniel Steffen <das@users.sourceforge.net>
* unix/Makefile.in (install-private-headers): rewrite tclPort.h when
installing private headers to remove ../unix relative #include path to
tclUnixPort.h (which is incorrect at the installed location).
2005-06-22 Kevin Kenny <kennykb@acm.org>
* generic/tclInt.h: Changed the finalization
* generic/tclEvent.c (Tcl_Finalize): logic to defer the
* generic/tclIO.c (TclFinalizeIOSubsystem): shutdown of the pipe
* unix/tclUnixPipe.c (TclFinalizePipes): management until after
* win/tclWinPipe.c (TclFinalizePipes): all channels have been
closed, in order to avoid a situation where the Windows
PipeCloseProc2 would re-establish the exit handler after exit
handlers had already run, corrupting the heap. [Bug 1225727]
Corrected a read of uninitialized memory in PipeCloseProc2, which (at
least on certain configurations) caused a great number of tests to
either fail or hang. [Bug 1225044]
2005-06-22 Andreas Kupries <andreask@activestate.com>
* generic/tclInt.h: Followup to change made on 2005-06-18 by Daniel
Steffen. There are compilers (*) who error out on the redefinition of
WORDS_BIGENDIAN. We have to undef the previous definition (on the
command line) first to make this acceptable. (*): AIX native.
2005-06-22 Don Porter <dgp@users.sourceforge.net>
* win/tclWinFile.c: Potential buffer overflow. [Bug 1225571]
Thanks to Pat Thoyts for discovery and fix.
* tests/safe.test: Backport performance improvement from
reduced $::auto_path.
2005-06-21 Pat Thoyts <patthoyts@users.sourceforge.net>
* tests/winDde.test: Added some waits to the dde server script to
let event processing run after we create the dde server and before
we exit the server process. This avoids 'server did not respond'
errors.
2005-06-21 Kevin Kenny <kennykb@acm.org>
* generic/tclFileName.c: Corrected a problem where a directory name
containing a colon can crash the process on Windows [Bug 1194458]
* tests/fileName.test: Added test for [file split] and [file join]
with a name containing a colon.
* win/tclWinPipe.c: Reverted davygrvy's changes of 2005-04-19;
they cause multiple failures in io.test. [Bug 1225044, still open]
2005-06-21 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c: Made the walk of the active trace list aware
* generic/tclCmdMZ.c: of the direction of trace scanning, so the
* generic/tclInt.h: proper correction can be made. [Bug 1224585]
* tests/trace.test (trace-34.2,3):
* generic/tclBasic.c (Tcl_DeleteTrace): Added missing walk of the
* tests/trace.test (trace-34.1): list of active traces to
cleanup references to traces being deleted. [Bug 1201035]
2005-06-20 Don Porter <dgp@users.sourceforge.net>
* doc/FileSystem.3: added missing Tcl_GlobTypeData documentation [Bug
935853]
2005-06-18 Daniel Steffen <das@users.sourceforge.net>
* generic/tclInt.h: ensure WORDS_BIGENDIAN is defined correctly with
fat compiles on Darwin (i.e. ppc and i386 at the same time), the
configure AC_C_BIGENDIAN check is not sufficient in this case because
a single run of the compiler builds for two architectures with
different endianness.
* unix/tcl.m4 (Darwin): add -headerpad_max_install_names to LDFLAGS to
ensure we can always relocate binaries with install_name_tool.
* unix/configure: autoconf-2.13
2005-06-18 Don Porter <dgp@users.sourceforge.net>
* changes: Update changes for 8.4.11 release
* README: Bump version number to 8.4.11
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure.in:
* unix/configure: autoconf
* win/configure:
2005-06-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclCmdAH.c (Tcl_FormatObjCmd): Fix for [Bug 1154163]; only
* tests/format.test: insert 'l' modifier when it is needed.
2005-06-07 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tclUnixNotfy.c (Tcl_FinalizeNotifier): Add dummy variable
so threaded build compiles.
2005-06-06 Kevin B. Kenny <kennykb@acm.org>
* win/tclWin32Dll.c: Corrected another buglet in the assembly code for
stack probing on Win32/gcc. [Bug 1213678]
2005-06-03 Daniel Steffen <das@users.sourceforge.net>
*** 8.4.10 TAGGED FOR RELEASE ***
* unix/tclLoadDyld.c: fixed header conflict when building this file
with USE_TCL_STUBS.
* macosx/Makefile: fixed 'embedded' target.
2005-06-02 Jeff Hobbs <jeffh@ActiveState.com>
* unix/Makefile.in (html): add BUILD_HTML_FLAGS optional var
* tools/tcltk-man2html.tcl: add a --useversion to prevent
confusion when multiple Tcl source dirs exist.
* changes: updated for 8.4.10 release (porter)
2005-05-31 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* unix/tclUnixNotfy.c: the notifier thread is now created as
joinable thread and it is properly joined in Tcl_FinalizeNotifier.
This is an attempt to fix [Bug 1082283]
2005-05-29 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinThrd.c (TclpFinalizeThreadData): move tlsKey defn
to top of file and clarify name (was 'key'). [Bug 1204064]
2005-05-27 Jeff Hobbs <jeffh@ActiveState.com>
* README: Bumped patchlevel to 8.4.10
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/tcl.spec, unix/configure, unix/configure.in:
* win/configure, win/configure.in:
2005-05-26 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: moved & corrected EMBEDDED_BUILD check.
* unix/configure.in: corrected framework finalization to softlink
stub library to Versions/8.x subdir instead of Versions/Current.
* unix/configure: autoconf-2.13
2005-05-25 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclCmdMZ.c (Tcl_TimeObjCmd): add necessary cast
* unix/configure, unix/configure.in: ensure false Tcl.framework is
only created with --enable-framework
2005-05-24 Daniel Steffen <das@users.sourceforge.net>
* tests/env.test: added DYLD_FRAMEWORK_PATH to the list of env vars
that need to be handled specially.
* macosx/Makefile:
* macosx/README:
* macosx/Tcl-Info.plist.in (new file):
* unix/Makefile.in:
* unix/configure.in:
* unix/tcl.m4:
* unix/tclUnixInit.c: moved all Darwin framework build support from
macosx/Makefile into the standard unix configure/make buildsystem, the
macosx/Makefile is no longer required to build Tcl.framework (but its
functionality is still available for backwards compatibility).
* unix/configure: autoconf-2.13
* generic/tclIOUtil.c (TclLoadFile):
* generic/tclInt.h:
* unix/tcl.m4:
* unix/tclLoadDyld.c: added support for [load]ing .bundle binaries in
addition to .dylib's: .bundle's can be [unload]ed (unlike .dylib's),
and can be [load]ed from memory, e.g. directly from VFS without
needing to be written out to a temporary location first. [Bug 1202209]
* unix/configure: autoconf-2.13
* generic/tclCmdMZ.c (Tcl_TimeObjCmd): change [time] called with a
count > 1 to return a string with a float value instead of a rounded
off integer. [Bug 1202178]
2005-05-20 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
* generic/tclParseExpr.c: removed unreferenced stack variable "errMsg"
probably included by fixing [Bug 1201589] (see below).
2005-05-20 Don Porter <dgp@users.sourceforge.net>
* generic/tclParseExpr.c: Corrected parser to recognize all
boolean literals accepted by Tcl_GetBoolean, including prefixes like
"y" and "f", and to allow "eq" and "ne" as function names in the
proper context. [Bug 1201589]
2005-05-19 Daniel Steffen <das@users.sourceforge.net>
* macosx/tclMacOSXNotify.c (Tcl_InitNotifier): fixed crashing
CFRelease of runLoopSource in Tcl_InitNotifier (reported by Zoran):
CFRunLoopAddSource doesn't CFRetain, so can only CFRelease the
runLoopSource in Tcl_FinalizeNotifier.
2005-05-14 Daniel Steffen <das@users.sourceforge.net>
* macosx/tclMacOSXBundle.c:
* unix/tclUnixInit.c:
* unix/tcl.m4 (Darwin): made use of CoreFoundation API configurable
and added test of CoreFoundation availablility to allow building on
ppc64, replaced HAVE_CFBUNDLE by HAVE_COREFOUNDATION; test for
availability of Tiger or later OSSpinLockLock API.
* unix/tclUnixNotfy.c:
* unix/Makefile.in:
* macosx/tclMacOSXNotify.c (new file): when CoreFoundation is
available, use new CFRunLoop based notifier: allows easy integration
with other event loops on Mac OS X, in particular the TkAqua Carbon
event loop is now integrated via a standard tcl event source (instead
of TkAqua upon loading having to finalize the exsting notifier and
replace it with its custom version). [Patch 1202052]
* tests/unixNotfy.test: don't run unthreaded tests on Darwin since
notifier may be using threads even in unthreaded core.
* unix/tclUnixPort.h:
* unix/tcl.m4 (Darwin): test for thread-unsafe realpath durning
configure, as Darwin 7 and later realpath is threadsafe.
* macosx/tclMacOSXBundle.c:
* unix/tclLoadDyld.c:
* unix/tclUnixInit.c: fixed gcc 4.0 warnings.
* unix/configure: autoconf-2.13
2005-05-10 Jeff Hobbs <jeffh@ActiveState.com>
* tests/string.test: string-10.[21-30]
* generic/tclCmdMZ.c (Tcl_StringObjCmd): add extra checks to
prevent possible UMR in unichar cmp function for string map.
2005-05-06 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tcl.m4, unix/configure: correct Solaris 10 (5.10) check and
add support for x86_64 Solaris cc builds.
2005-04-29 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/FileSystem.3: Backport of doc fix. [Bug 1172401]
2005-04-27 Don Porter <dgp@users.sourceforge.net>
* library/init.tcl: Corrected flaw in interactive command
* tests/main.test: auto-completion. [Bug 1191409]
* tests/unixInit.test (7.1): Alternative fix for the
2005-04-22 commit.
2005-04-25 Daniel Steffen <das@users.sourceforge.net>
* compat/string.h: fixed memchr() protoype for __APPLE__ so that we
build on Mac OS X 10.1 again.
* generic/tclNotify.c (TclFinalizeNotifier): fixed notifier not being
finalized in unthreaded core (was testing for notifier initialization
in current thread by checking thread id != 0 but thread id is always 0
in untreaded core).
* unix/tclUnixNotfy.c (Tcl_WaitForEvent): sync with HEAD: only declare
and use timeout var in unthreaded core.
* unix/Makefile.in: added @PLAT_SRCS@ to SRCS and split out
NOTIFY_SRCS from UNIX_SRCS for parity with UNIX_OBJS & NOTIFY_OBJS.
* unix/configure.in: only run check for broken strstr implementation
if AC_REPLACE_FUNCS(strstr) hasn't already determined that strstr is
unavailable, otherwise compat/strstr.o will be used twice (resulting
in duplicate symbol link errors on Mac OS X 10.1)
* unix/tcl.m4 (Darwin): added configure checks for recently added
linker flags -single_module and -search_paths_first to allow building
with older tools (and on Mac OS X 10.1), use -single_module in
SHLIB_LD and not just T{CL,K}_SHLIB_LD_EXTRAS, added unexporting from
Tk of symbols from libtclstub to avoid duplicate symbol warnings,
added PLAT_SRCS definition for Mac OS X.
(SC_MISSING_POSIX_HEADERS): added caching of dirent.h check.
(SC_TCL_64BIT_FLAGS): fixed 'checking for off64_t' message output.
* unix/configure: autoconf-2.13
2005-04-22 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdMZ.c: Corrected intrep-dependence of
* tests/string.test: [string is boolean] [Bug 1187123]
2005-04-22 Daniel Steffen <das@users.sourceforge.net>
* tests/unixInit.test (7.1): fixed failure when running tests with
-tmpdir arg not set to working dir.
2005-04-20 Don Porter <dgp@users.sourceforge.net>
* generic/tclGet.c (Tcl_GetInt): Corrected error that did not
* generic/tclObj.c (Tcl_GetIntFromObj): permit 0x80000000 to be
recognized as an integer on TCL_WIDE_INT_IS_LONG systems [Bug 1090869]
2005-04-19 Jeff Hobbs <jeffh@ActiveState.com>
* tests/winPipe.test (winpipe-6.2): remove -blocking 1 as this one
can truly block.
2005-04-19 David Gravereaux <davygrvy@pobox.com>
* win/tclWinPipe.c: The pipe channel driver now respects the -blocking
option when closing. The windows pipe driver now has the same behavior
as the UNIX side. This change is to avoid a hung shell when exiting
due to open pipes that refuse to close in a graceful manner.
* doc/open.n: Added a note about -blocking 0 and lack of exit status
as it had never been documented. [Bug 947693]
***POTENTIAL INCOMPATIBILITY***
Scripts that use async pipes on windows, must (like the UNIX side) set
-blocking to 1 before calling [close] to receive the exit status.
* tests/winPipe.test (winpipe-6.1/2): added 'fconfigure $f -blocking
1' so the exit status can be acquired.
2005-04-13 David Gravereaux <davygrvy@pobox.com>
* generic/tclIO.c (Tcl_SetChannelBufferSize): Lowest size limit
* tests/io.test: changed from ten bytes to one byte. Need for
* tests/iogt.test: this change was proven by Ross Cartlidge
<rossc@cisco.com> where [read stdin 1] was grabbing 10 bytes followed
by starting a child process that was intended to continue reading from
stdin. Even with -buffersize set to one, nine chars were getting lost
by the buffersize over reading for the native read() caused by [read].
2005-04-12 Kevin B. Kenny <kennykb@acm.org>
* compat/strstr.c: Added default definition of NULL to accommodate
building on systems with badly broken headers. [Bug 1175161]
2005-04-09 Daniel Steffen <das@users.sourceforge.net>
* macosx/README: updated requirements for OS & developer tool versions
+ other small fixes/cleanup.
* unix/tcl.m4 (Darwin): added -single_module linker flag to
TCL_SHLIB_LD_EXTRAS and TK_SHLIB_LD_EXTRAS.
* unix/configure: autoconf-2.13
2005-04-05 Zoran Vasiljevic <vasiljevic@users.sourceforge.net>
Set of changes correcting huge memory waste (not a leak) when a thread
exits. This has been introduced in 8.4.7 within an attempt to
correctly cleanup after ourselves when Tcl library is being unloaded
with the Tcl_Finalize() call.
This fixes the [Bug 1178445].
* generic/tclInt.h: added prototypes for TclpFreeAllocCache() and
TclFreeAllocCache()
* generic/tclThreadAlloc.c: modified TclFinalizeThreadAlloc() to
explicitly call TclpFreeAllocCache with the NULL-ptr as argument
signalling cleanup of private tsd key used only by the threading
allocator.
* unix/tclUnixThrd.c: fixed TclpFreeAllocCache() to recognize when
being called with NULL argument. This is a signal for it to clean up
the tsd key associated with the threading allocator.
* win/tclWinThrd.c: renamed TclWinFreeAllocCache to TclpFreeAllocCache
and fixed to recognize when being called with NULL argument. This is a
signal for it to clean up the tsd key associated with the threading
allocator.
2005-04-05 Don Porter <dgp@users.sourceforge.net>
* generic/tclExecute.c (ExprSrandFunc): Replaced incursions into the
* generic/tclUtil.c (TclGetIntForIndex): intreps of numeric types with
simpler calls of Tcl_GetIntFromObj and Tcl_GetLongFromObj, now that
those routines are better behaved wrt shimmering. [Patch 1177129]
2005-03-29 Jeff Hobbs <jeffh@ActiveState.com>
* win/tcl.m4, win/configure: do not require cygpath in macros to
allow msys alone as an alternative.
* win/tclWinTime.c (TclpGetDate): use time_t for 'time' [Bug 1163422]
2005-03-18 Don Porter <dgp@users.sourceforge.net>
* generic/tclCompCmds.c (TclCompileIncrCmd): Corrected checks for
immediate operand usage to permit leading space and sign characters.
Restores more efficient bytecode for [incr x -1] that got lost in the
CONST string reforms of Tcl 8.4. [Bug 1165671]
* generic/tclBasic.c (Tcl_EvalEx,TclEvalTokensStandard):
* generic/tclCmdMZ.c (Tcl_SubstObj):
* tests/basic.test (basic-46.4): Restored recursion limit
* tests/parse.test (parse-19.*): testing in nested command
substitutions within direct script evaluation (Tcl_EvalEx) that got
lost in the parser reforms of Tcl 8.1. Added tests for correct
behavior. [Bug 1115904]
2005-03-15 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFileName.c:
* win/tclWinFile.c:
* tests/winFCMd.test: fix to 'file pathtype' and 'file norm' failures
on reserved filenames like 'COM1:', etc.
2005-03-15 Kevin B. Kenny <kennykb@acm.org>
* generic/tclClock.c:
* generic/tclDate.c:
* generic/tclGetDate.y:
* generic/tclInt.decls:
* unix/tclUnixTime.c:
* win/tclWinTime.c: Replaced 'unsigned long' variable holding
times with 'Tcl_WideInt', to cope with systems on which a time_t is
wider than a long (Win64) [Bug 1163422]
* generic/tclIntDecls.h: Regen
2005-03-15 Pat Thoyts <patthoyts@users.sourceforge.net>
* unix/tcl.m4: Make it work on OpenBSD again. Imported patch
from the OpenBSD ports tree.
2005-03-10 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdMZ.c (TclCheckInterpTraces): Corrected mistaken
cast of ClientData to (TraceCommandInfo *) when not warranted. Thanks
to Yuri Victorovich for the report. [Bug 1153871]
2005-03-08 Jeff Hobbs <jeffh@ActiveState.com>
* win/makefile.vc: clarify necessary defined vars that can come
from MSVC or the Platform SDK.
2005-02-24 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Better use of [glob -types] to avoid
* tests/tcltest.test: failed attempts to [source] a directory, and
similar matters. Thanks to "mpettigr". [Bug 1119798]
* library/tcltest/pkgIndex.tcl: Bump to tcltest 2.2.8
2005-02-23 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/CrtChannel.3 (THREADACTIONPROC): Formatting fix. [Bug 1149605]
2005-02-17 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinFCmd.c (TraverseWinTree): use wcslen on wchar, not
Tcl_UniCharLen.
2005-02-16 Miguel Sofer <msofer@users.sf.net>
* doc/variable.n: fix for [Bug 1124160], variables are detected by
[info vars] but not by [info locals].
2005-02-10 Jeff Hobbs <jeffh@ActiveState.com>
* unix/Makefile.in: remove SHLIB_LD_FLAGS (only for AIX, inlined
* unix/tcl.m4: into SHLIB_LD). Combine AIX-* and AIX-5
* unix/configure: branches in SC_CONFIG_CFLAGS.
Correct gcc builds for AIX-4+ and HP-UX-11.
2005-02-10 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c (Tcl_EvalObjEx):
* tests/basic.test (basic-26.2): preserve the arguments passed to TEOV
in the pure-list branch, in case the list shimmers away. Fix for [Bug
1119369], reported by Peter MacDonald.
2005-02-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/binary.n: Made the documentation of sign bit masking and
[binary scan] consistent. [Bug 1117017]
2005-02-01 Don Porter <dgp@users.sourceforge.net>
* generic/tclExecute.c (TclCompEvalObj): Removed stray statement
left behind in prior code reorganization.
2005-01-28 Jeff Hobbs <jeffh@ActiveState.com>
* unix/configure, unix/tcl.m4: add solaris 64-bit gcc build
support. [Bug 1021871]
2005-01-27 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclBasic.c (Tcl_ExprBoolean, Tcl_ExprDouble)
(Tcl_ExprLong): Fix to recognize Tcl_WideInt type. [Bug 1109484]
2005-01-27 Andreas Kupries <andreask@activestate.com>
TIP#218 IMPLEMENTATION
* generic/tclDecls.h: Regenerated from tcl.decls.
* generic/tclStubInit.c:
* doc/CrtChannel.3: Documentation of extended API,
* generic/tcl.decls: extended testsuite, and
* generic/tcl.h: implementation. Removal of old
* generic/tclIO.c: driver-specific TclpCut/Splice
* generic/tclInt.h: functions. Replaced with generic
* tests/io.test: thread-action calls through the
* unix/tclUnixChan.c: new hooks. Update of all builtin
* unix/tclUnixPipe.c: channel drivers to version 4.
* unix/tclUnixSock.c: Windows drivers extended to
* win/tclWinChan.c: manage thread state in a thread
* win/tclWinConsole.c: action handler.
* win/tclWinPipe.c:
* win/tclWinSerial.c:
* win/tclWinSock.c:
* mac/tclMacChan.c:
2005-01-25 Don Porter <dgp@users.sourceforge.net>
* library/auto.tcl: Updated [auto_reset] to clear auto-loaded
procs in namespaces other than :: [Bug 1101670].
2005-01-25 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4 (Darwin): fixed bug with static build linking to dynamic
library in /usr/lib etc instead of linking to static library earlier
in search path. [Bug 956908]
Removed obsolete references to Rhapsody.
* unix/configure: autoconf-2.13
2005-01-19 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWinChan.c (FileCloseProc): Invoke TclpCutFileChannel() to
remove a FileInfo from the thread local list before deallocating it.
This should have been done via an earlier call to Tcl_CutChannel, but
I was running into a crash in the next call to Tcl_CutChannel during
the IO finalization stage.
2005-01-17 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/winFCmd.test: made test independent of current drive. [Bug
1066528]
2005-01-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tclUnixFCmd.c (CopyFile): Convert u_int to unsigned to make
clashes with types in standard C headers less of a problem. [Bug
1098829]
2005-01-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* library/http/http.tcl (http::mapReply): Significant performance
enhancement by using [string map] instead of [regsub]/[subst], and
update version requirement to Tcl8.4. [Bug 1020491]
2005-01-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tclUnixInit.c (localeTable): Add encoding mappings for some
Chinese locales. [Bug 1084595]
* doc/lsearch.n: Convert to other form of emacs mode control
comment to prevent problems with old versions of man. [Bug 1085127]
2004-12-29 Jeff Hobbs <jeffh@ActiveState.com>
* win/tcl.m4, win/configure: update MSVC CFLAGS_OPT to -O2, remove
-Gs (included in -O2) and -GD (outdated). Use "link -lib" instead
of "lib" binary and remove -YX for MSVC7 portability. Add
-fomit-frame-pointer for gcc OPT compiles. [Bug 1092952, 1091967]
2004-12-13 Kevin B. Kenny <kennykb@acm.org>
* doc/clock.n: Clarify that the [clock scan] command does not accept
the full range of ISO8601 point-in-time formats. [Bug 1075433]
2004-12-09 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/Async.3: Reword for better grammar, better nroff and get the
flag name right. (Reported by David Welton.)
2004-12-06 Jeff Hobbs <jeffh@ActiveState.com>
*** 8.4.9 TAGGED FOR RELEASE ***
* unix/tclUnixNotfy.c (NotifierThreadProc): init numFdBits [Bug
1079286]
2004-12-02 Jeff Hobbs <jeffh@ActiveState.com>
* changes: updated for 8.4.9 release
2004-12-02 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c: fix and new tests for [Bug 1074671] to
* tests/fileSystem.test: ensure tilde paths are not returned specially
by 'glob'.
2004-12-01 Don Porter <dgp@users.sourceforge.net>
* library/auto.tcl (tcl_findLibrary): Disabled use of [file normalize]
that caused trouble with freewrap. [Bug 1072136]
2004-11-26 Don Porter <dgp@users.sourceforge.net>
* tests/reg.test (reg-32.*): Added missing testregexp constraints.
* library/auto.tcl (tcl_findLibrary): Made sure the uniquifying
operations on the search path does not also normalize. [Bug 1072136]
2004-11-26 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/dde.n: Resynchonized the documentation with itself and fixed
some formatting errors.
2004-11-25 Zoran Vasiljevic <vasiljevic@users.sf.net>
* doc/Notify.3:
* doc/Thread.3: Added doc fixes and hints from [Bug 1068077].
2004-11-25 Reinhard Max <max@suse.de>
* tests/tcltest.test: The order in which [glob] returns the file names
* tests/fCmd.test: is undefined, so tests should not depend on it.
2004-11-24 Don Porter <dgp@users.sourceforge.net>
* unix/tcl.m4 (SC_ENABLE_THREADS): Corrected failure to determine
the number of arguments for readdir_r on SunOS systems. [Bug 1071701]
* unix/configure: autoconf-2.13
2004-11-24 Jeff Hobbs <jeffh@ActiveState.com>
* README: Bumped patchlevel to 8.4.9
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/tcl.spec, unix/configure, unix/configure.in:
* win/configure, win/configure.in:
2004-11-24 Kevin B. Kenny <kennykb@acm.org>
* unix/tcl.m4 (SC_ENABLE_THREADS): Corrected bad check for 3-argument
readdir_r(). [Bug 1001325]
* unix/configure: Regenerated.
* unix/tclUnixNotfy.c: Corrected all uses of 'select' to manage their
masks using the FD_CLR, FD_ISSET, FD_SET, and FD_ZERO macros rather
than bit-whacking that failed under Solaris-Sparc-64. [Bug 1071807]
2004-11-23 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdIL.c (InfoVarsCmd): Corrected segfault in new
* tests/info.test (info-19.6): trivial matching branch [Bug 1072654]
2004-11-23 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclPathObj.c: fix and new test for [Bug 1043129] in
* tests/fileSystem.test: the treatment of backslashes in file join on
Windows.
2004-11-22 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4 (SC_TCL_64BIT_FLAGS): Define HAVE_TYPE_OFF64_T only when
off64_t, open64(), and lseek64() are defined. IRIX 5.3 is known to not
include an open64 function. [Bug 1030465]
2004-11-22 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4 (SC_ENABLE_THREADS): Check for a 2 argument version of
readdir_r that is known to exists under IRIX 5.3.
* unix/tclUnixThrd.c (TclpReaddir): Use either 2 arg or 3 arg version
of readdir_r. [Bug 1001325]
2004-11-19 Reinhard Max <max@suse.de>
*** 8.4.8 TAGGED FOR RELEASE ***
* unix/installManPage: Classic sed doesn't support | in REs.
2004-11-19 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile:
* unix/configure.in:
* unix/tclUnixInit.c (MacOSXGetLibraryPath): changed detection of tcl
framework build when determining tclLibPath from overloaded
TCL_LIBRARY to configuration define TCL_FRAMEWORK. [Bug 1068088]
* unix/configure: autoconf-2.13
* tests/unixInit.test (7.1): fixed failure when running tests
with -tmpdir arg not set to working dir.
2004-11-18 Don Porter <dgp@users.sourceforge.net>
* changes: Final updates for Tcl 8.4.8 release.
2004-11-18 Reinhard Max <max@suse.de>
* unix/tcl.m4 (SC_CONFIG_MANPAGES): Applied an improved version of
* unix/configure.in: [Patch 996085], that introduces
* unix/Makefile.in: --enable-man-suffix.
* unix/installManPage: added
* unix/mkLinks.tcl: removed
* unix/mkLinks: removed
2004-11-16 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixChan.c (TtySetOptionProc): fixed crash configuring
-ttycontrol on a channel. [Bug 1067708]
2004-11-16 Andreas Kupries <andreask@activestate.com>
* win/makefile.vc: Fixed bug in installation of http 2.5.
* win/makefile.bc: Was installed into directory http2.4.
* win/Makefile.in: This has been corrected.
* unix/Makefile.in:
* tools/tcl.wse.in:
* tools/tclmin.wse:
2004-11-16 Don Porter <dgp@users.sourceforge.net>
* library/auto.tcl: Updated [tcl_findLibrary] search path to
include the $::auto_path. [RFE 695441]
2004-11-16 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/tclvars.n: Mention global variables set by tclsh and wish so
they are easier to find. [Patch 1065732]
2004-11-15 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdMZ.c (Tcl_TraceObjCmd): Fixed Bug 1065378 which failed
* tests/trace.test (trace-33.1): to permit a variable trace
created with [trace variable] to be destroyed with [trace remove].
Thanks to Keith Vetter for the report.
2004-11-12 Don Porter <dgp@users.sourceforge.net>
* library/init.tcl: Made [unknown] robust in the case that either
of the variables ::errorInfo or ::errorCode gets unset. [Bug 1063707]
2004-11-12 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclEncoding.c (TableFromUtfProc): correct crash
condition when TCL_UTF_MAX == 6. [Bug 1004065]
2004-11-12 Daniel Steffen <das@users.sourceforge.net>
* doc/clock.n:
* doc/registry.n:
* doc/upvar.n: fixed *roff errors uncovered by running 'make html'.
* tools/tcltk-man2html.tcl: added faked support for bullet point
lists, i.e. *nroff ".IP \(bu" syntax.
Synced other changes from HEAD.
2004-11-11 Daniel Steffen <das@users.sourceforge.net>
* tests/fCmd.test:
* unix/tclUnixFCmd.c (TraverseUnixTree): added option to rewind() the
readdir() loop whenever the source hierarchy has been modified by
traverseProc (e.g. by deleting files); this is required to ensure
complete traversal of the source hierarchy on certain filesystems like
HFS+. Added test for failing recursive delete on Mac OS X that was due
to this. [Bug 1034337]
* generic/tclListObj.c (Tcl_ListObjReplace): use memmove() instead of
manual copy loop to shift list elements. Decreases time spent in
Tcl_ListObjReplace() from 5.2% to 1.7% of overall runtime of tclbench
on a ppc 7455 (i.e. 200% speed increase). [Patch 1064243]
* generic/tclHash.c: hoisted some constant pointer dereferences out of
loops to eliminate redundant loads that the gcc optimizer didn't deal
with. Decreases time spend in Tcl_FindHashEntry() by 10% over a full
run of the tcl testuite on a ppc 7455. [Patch 1064243]
* tests/fileName.test:
* tests/fileSystem.test:
* tests/io.test:
* tests/tcltest.test: fixed bugs causing failures when running tests
with -tmpdir arg not set to working dir.
* macosx/Makefile: corrected path to html help inside framework.
Prevent parallel make from building several targets at the same time.
2004-11-09 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/catch.n: Clarify documentation on return codes. [Bug 1062647]
2004-11-02 Don Porter <dgp@users.sourceforge.net>
* changes: Updates for Tcl 8.4.8 release.
2004-11-02 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Corrected some misleading
* tests/tcltest.test (tcltest-26.1,2): displays of ::errorInfo and
::errorCode information when the -setup, -body, and/or -cleanup scripts
return an unexpected return code. Thanks to Robert Seeger for the
fix. [RFE 1017151]
2004-11-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclExecute.c (TclExecuteByteCode): NaN-equality fix from
Miguel Sofer. [Bug 761471]
* doc/CrtChannel.3 (Tcl_GetChannelMode): Add synopsis. [Bug 1058446]
2004-10-31 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclCmdIL.c (InfoGlobalsCmd):
* tests/info.test (info-8.4): Strip leading global-namespace
specifiers from the pattern argument. [Bug 1057461]
2004-10-30 Miguel Sofer <msofer@users.sf.net>
* generic/tclCmdAH.c (Tcl_CatchObjCmd): removed erroneous comment [Bug
1029518]
2004-10-29 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Correct reaction to errors in the
obsolete processCmdLineArgsHook. [Bug 1055673]
* library/tcltest/pkgIndex.tcl: Bump to tcltest 2.2.7
2004-10-28 Andreas Kupries <andreask@activestate.com>
* generic/tclAlloc.c: Fixed [Bug 1030548], a threaded debug
* generic/tclThreadAlloc.c: build on Windows now works again. Had to
* win/tclWinThrd.c: touch Unix as well. Basic patch by Kevin,
* unix/tclUnixThrd.c: with modifications by myself.
2004-10-28 Don Porter <dgp@users.sourceforge.net>
* README: Bumped patch level to 8.4.8 to prepare for
* generic/tcl.h: next patch release.
* tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure.in:
* unix/configure: autoconf (2.13)
* win/configure:
2004-10-28 Kevin B. Kenny <kennykb@acm.org>
* generic/tclInt.decls:
* unix/tclUnixTime.c (TclpGmtime, TclpLocaltime):
* win/tclWinTime.c (TclpGmtime, TclpLocaltime): Changed type
signatures of TclpGmtime and TclpLocaltime to accept CONST TclpTime_t
throughout, to avoid any possible confusion in pedantic compilers.
[Bug 1001319]
* generic/tclIntDecls.h:
* generic/tclIntPlatDecls.h: Regenerated.
2004-10-27 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdAH.c (Tcl_FormatObjCmd): Restored missing line
from yesterday's 868489 backport that caused failed alloc's on LP64
systems.
* tests/appendComp.test: Backport test suite fixes of errors
* tests/autoMkindex.test: revealed by -singleproc 1 -debug 1
* tests/exec.test: options to make test.
* tests/execute.test:
* tests/interp.test:
* tests/io.test:
* tests/namespace.test:
* tests/regexpComp.test:
* tests/stringComp.test:
* tests/unixInit.test:
* tests/winPipe.test:
2004-10-26 Kevin B. Kenny <kennykb@acm.org>
* generic/tclCmdAH.c (Tcl_FormatObjCmd): Backport a missing bit of the
[Bug 868489] fix.
* generic/tclObj.c (SetBooleanFromAny): Backport fix for [Bug 1026125]
* tests/format.test (format-19.1): Additional regression test for
[Bug 868489].
2004-10-26 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/*.n: Backporting of documentation updates.
2004-10-26 Don Porter <dgp@users.sourceforge.net>
* tests/subst.test (subst-12.3-5): More tests for [Bug 1036649]
* tests/compile.test (compile-12.4): Backport test for [Bug 1001997]
* tests/timer.test (timer-10.1): Backport test for [Bug 1016167]
* tests/tcltest.test (tcltest-12.3,4): Backport setup corrections.
* tests/error.test (error-6.3,4,7,9): Backport of some tests.
* tests/basic.test (basic-49.*):
* tests/namespace.test (namespace-8.7):
* tests/init.test (init-2.8): Updated to not rely on http package.
* generic/tclThreadTest.c (ThreadEventProc): Corrected subtle bug
where the returned (char *) from Tcl_GetStringResult(interp) continued
to be used without copying or refcounting, while activity on the
interp continued.
2004-10-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclUtil.c (TclMatchIsTrivial): Detect degenerate cases of
glob matching that let us avoid scanning through hash tables.
* generic/tclCmdIL.c (InfoCommandsCmd, InfoGlobalsCmd, InfoProcsCmd):
(InfoVarsCmd): Use this to speed up some [info] subcommands.
2004-10-08 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinFile.c (NativeIsExec): correct result of 'file executable'
to not be case sensitive. [Bug 954263]
2004-10-05 Don Porter <dgp@users.sourceforge.net>
* generic/tclNamesp.c (Tcl_PopCallFrame): Removed Bug 1038021
workaround. That bug is now fixed.
2004-09-30 Don Porter <dgp@users.sourceforge.net>
* generic/tclNamespace.c (TclTeardownNamespace): Tcl_Obj-ified the
* tests/namespace.test (namespace-8.5,6): save/restore of
::errorInfo and ::errorCode during global namespace teardown. Revised
the comment to clarify why this is done, and added tests that will
fail if this is not done.
* generic/tclResult.c (TclTransferResult): Added safety checks so
that unexpected undefined ::errorInfo or ::errorCode will not lead to
a segfault.
* generic/tclVar.c (CallVarTraces): Save/restore the flag values
* tests/var.test (var-16.1): that define part of the interpreter
state during variable traces. [Bug 1038021]
2004-09-30 Miguel Sofer <msofer@users.sf.net>
* tests/subst.test (12.2): test correction.
2004-09-29 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c (Tcl_EvalEx):
* tests/subst.test (12.1-2): fix for buffer overflow in [subst], [Bug
1036649]
2004-09-23 Mo DeJong <mdejong@users.sourceforge.net>
* unix/dltest/Makefile.in (clean): Fixup make clean rule so that it
does not delete all files when SHLIB_SUFFIX is set to the empty string
in a static build. [Bug 1016726]
2004-09-18 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclExecute.c (TEBC-INST_LSHIFT,INST_RSHIFT): Ensure that
large shifts end up shifting correctly. [Bug 868467]
2004-09-15 Daniel Steffen <das@users.sourceforge.net>
* tests/load.test (load-2.3): adopted fix for failure on darwin from
HEAD.
2004-09-14 Don Porter <dgp@users.sourceforge.net>
* generic/tclObj.c (Tcl_GetIntFromObj): Corrected flaw in returning
the int value of a wideInteger. [Bug 1027690]
2004-09-10 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclObj.c (SetIntOrWideFromAny): Rewritten integral value
parsing code so that values do not flip so easily between numeric
representations. Thanks to KBK for this! [Bug 868489]
* generic/tclIO.c (Tcl_Seek): Make sure wide seeks do not fail to set
::errorCode on error. [Bug 1025359]
2004-09-10 Andreas Kupries <andreask@activestate.com>
* generic/tcl.h: Micro formatting fixes.
* generic/tclIOGT.c: Channel version fixed, must be 3, to have
wideseekProc. Thanks to David Graveraux <davygrvy@pobox.com>.
2004-09-11 Don Porter <dgp@users.sourceforge.net>
* generic/tclNamespace.c (TclGetNamespaceForQualName): Resolved
longstanding inconsistency in the treatment of the TCL_NAMESPACE_ONLY
flag revealed by testing the 2004-09-09 commits against Itcl.
TCL_NAMESPACE_ONLY now acts as specified in the pre-function
comment, forcing resolution in the passed in context namespace. It has
been incorrectly forcing resolution in the interp's current namespace.
2004-09-10 Miguel Sofer <msofer@users.sf.net>
* generic/tclExecute.c (INST_CONCAT1): added a peephole optimisation
for concatting an empty string. This enables replacing the idiom 'K $x
[set x {}]' by '$x[set x {}]' for fastest execution.
2004-09-09 Don Porter <dgp@users.sourceforge.net>
* generic/tclNamesp.c (Tcl_ForgetImport): Corrected faulty logic that
* tests/namespace.test: relied exclusively on string matching and
failed in the presence of [rename]s. [Bug 560297]
Also corrected faulty prevention of [namespace import] cycles. [Bug
1017299]
2004-09-08 Kevin B. Kenny <kennykb@acm.org>
* compat/strftime.c (_conv): Corrected a problem where hour 0 would
format as a blank format group with %k.
* tests/clock.test (clock-41.1): Added regression test case for %k at
the zero hour.
2004-09-07 Kevin B. Kenny <kennykb@acm.org>
* generic/tclTimer.c: Removed a premature optimisation that attempted
to store the assoc data in the client data; the optimisation caused a
bug that [after] would overwrite its imports. [Bug 1016167]
2004-09-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/lsearch.n: Clarified meaning of -dictionary. [Bug 759545]
2004-09-01 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinReg.c (BroadcastValue): WIN64 cast corrections
* win/tclWinDde.c (DdeClientWindowProc):
(DdeServicesOnAck, DdeEnumWindowsCallback): WIN64 corrections
* win/tclWin32Dll.c (TclWinCPUID): need _asm for WIN64 (Itanium),
until we have it, just return unknown. [Bug 1020445]
2004-08-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclCmdMZ.c (Tcl_StringObjCmd): Stop [string map] from
crashing when its map and input string are the same object.
2004-08-27 Daniel Steffen <das@users.sourceforge.net>
* tests/env.test: macosx fixes.
2004-08-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclScan.c (Tcl_ScanObjCmd, ValidateFormat): Ensure that the
%ld conversion works correctly on 64-bit platforms. [Bug 1011860]
2004-08-16 Miguel Sofer <msofer@users.sf.net>
* doc/SetVar.3:
* generic/tclTest.c (TestseterrorcodeCmd):
* generic/tclVar.c (TclPtrSetVar):
* tests/result.test (result-4.*, result-5.*): [Bug 1008314]
detected and fixed by dgp.
2004-08-13 Don Porter <dgp@users.sourceforge.net>
* library/msgcat/msgcat.tcl: Added checks to prevent [mclocale]
* tests/msgcat.test: from registering filesystem paths to possibly
malicious code to be evaluated by a later [mcload].
* library/msgcat/pkgIndex.tcl: Bump to msgcat 1.3.3
2004-08-10 Zoran Vasiljevic <vasiljevic@users.sf.net>
* unix/tclUnixThrd.c (TclpThreadCreate): changed handling of the
returned thread ID since broken on 64-bit systems (Cray). Thanks to
Rob Ratcliff for reporting the bug.
2004-07-30 Don Porter <dgp@users.sourceforge.net>
* generic/tclEvent.c (Tcl_Finalize): Re-organized Tcl_Finalize so
that Tcl_ExitProc's that call Tcl_Finalize recursively do not cause
deadlock. [Patch 999084, fixes Tk Bug 714956]
2004-07-30 Daniel Steffen <das@users.sourceforge.net>
* unix/configure:
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Darwin: instead of setting PLAT_OBJS
to explict object files in tcl.m4, refer to MAC_OSX_OBJS makefile var.
* unix/Makefile.in: added MAC_OSX_OBJS variable.
2004-07-28 Don Porter <dgp@users.sourceforge.net>
* generic/tclMain.c (Tcl_Main, StdinProc): Append newline only to
* tests/basic.test (basic-46.1): incomplete scripts as part
of multi-line script construction. Do not add an extra trailing
newline to the complete script. [Bug 833150]
2004-07-26 Jeff Hobbs <jeffh@ActiveState.com>
*** 8.4.7 TAGGED FOR RELEASE ***
* tests/io.test (io-61.1): create file in binary mode for x-plat.
2004-07-25 Pat Thoyts <patthoyts@users.sourceforge.net>
* generic/tclThreadAlloc.c: Moved the tclInt.h include to provide
Tcl_Panic which is now required for non-threaded build.
2004-07-22 Don Porter <dgp@users.sourceforge.net>
* tests/eofchar.data (removed): Test io-61.1 now generates its own
* tests/io.test: file of test data as needed.
2004-07-21 Don Porter <dgp@users.sourceforge.net>
* win/tclWinDde.c: Bump to dde 1.2.3 to cover changes
* library/dde/pkgIndex.tcl: committed on 2004-06-14.
* changes: Updated for Tcl 8.4.7 release.
2004-07-20 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclEvent.c: Correct threaded obj allocator to
* generic/tclInt.h: fully cleanup on exit and allow for
* generic/tclThreadAlloc.c: reinitialization. [Bug 736426]
* unix/tclUnixThrd.c: (mistachkin, kenny)
* win/tclWinThrd.c:
2004-07-20 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4: fixed Darwin autoconf breakage caused by recent CFLAGS
reordering.
* unix/configure: regen
* unix/tclConfig.sh.in: replaced EXTRA_CFLAGS with CFLAGS.
* unix/dltest/Makefile.in: replaced EXTRA_CFLAGS with DEFS.
* macosx/tclMacOSXBundle.c: dynamically acquire address for
CFBundleOpenBundleResourceMap symbol, since it is only present in
full CoreFoundation on Mac OS X and not in CFLite on pure Darwin.
2004-07-19 Jeff Hobbs <jeffh@ActiveState.com>
* unix/Makefile.in, unix/tcl.m4: move (C|LD)FLAGS after their
* unix/configure.in, unix/configure: _DEFAULT to allow for env setting
to override m4 switches.
Consolidate header checks to limit redundancy in configure.
(CFLAGS_WARNING): Remove -Wconversion, add -fno-strict-aliasing for
gcc builds (need to suppress 3.x type puning warnings).
(SC_ENABLE_THREADS): Set m4 to force threaded build when built against
a threaded Tcl core.
Reorder configure.in for better 64-bit build configuration, replacing
EXTRA_CFLAGS with CFLAGS. [Bug 874058]
2004-07-19 Zoran Vasiljevic <vasiljevic@users.sf.net>
* win/tclwinThrd.c: redefined MASTER_LOCK to call TclpMasterLock.
Fixes [Bug 987967]
2004-07-16 Andreas Kupries <andreask@activestate.com>
* generic/tclIOCmd.c (Tcl_FcopyObjCmd): Corrected a typo in the
generation of error messages and simplified by reusing data in a
variable instead of retrieving the string again. Fixes [Bug 835289]
* doc/OpenFileChnl.3: Added description of the behaviour of
Tcl_ReadChars when its 'charsToRead' argument is set to -1. Fixes [Bug
934511]
* doc/CrtCommand.3: Added note that the arguments given to the command
proc of a Tcl_CreateCommand are in utf8 since Tcl 8.1. Closing [Patch
414778]
* doc/ChnlStack.3: Removed the declaration that the interp argument to
Tcl_(un)StackChannel can be NULL. This fixes [Bug 881220], reported by
Marco Maggi <marcomaggi@users.sourceforge.net>.
* tests/socket.test: Accepted two new testcases by Stuart Casoff
<stwo@users.sourceforge.net> checking that -server and -async don't go
together [Bug 796534]
* unix/tclUnixNotfy.c (NotifierThreadProc): Accepted Joe Mistachkin's
patch for [Bug 990500], properly closing the notifier thread when its
exits.
2004-07-15 Andreas Kupries <andreask@activestate.com>
* unix/tclUnixThrd.c (TclpFinalizeMutex): Accepted Joe Mistachkin's
patch for [Bug 990453], closing leakage of mutexes. They were not
destroyed properly upon finalization.
2004-07-15 Zoran Vasiljevic <vasiljevic@users.sf.net>
* generic/tclEvent.c (NewThreadProc): Backout of changes to fix [Bug
770053]. See SF bugreport for more info.
* generic/tclNotify.c (TclFinalizeNotifier): Added conditional
notifier finalization based on the fact that an TclInitNotifier has
been called for the current thread. This fixes [Bug 770053] again.
Hopefully this time w/o unwanted side-effects.
2004-07-14 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.h (CHANNEL_INCLOSE): New flag. Set in Tcl_Close
* generic/tclIO.c (Tcl_UnregisterChannel): while the close callbacks
* generic/tclIO.c (Tcl_Close): are run. Checked in
Tcl_Close and Tcl_Unregister to prevent recursive call of [close] in
the close-callbacks. This is a possible error made by implementors of
virtual filesystems based on 'tclvfs', thinking that they have to
close the channel in the close handler for the filesystem.
2004-07-14 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.c:
* generic/tclIO.h:
Not reverting, but #ifdef'ing the changes from May 19, 2004 out of the
core. This removes the ***POTENTIAL INCOMPATIBILITY*** for channel
drivers it introduced. This has become possible due to Expect gaining
a BlockModeProc and now handling blockingg and non-blocking modes
correctly. Thus [Bug 943274] is still fixed if a recent enough version
of Expect is used.
* doc/CrtChannel.3: Added warning about usage of a channel without a
BlockModeProc.
2004-07-15 Andreas Kupries <andreask@pliers.activestate.com>
* generic/tclIOCmd.c (Tcl_PutsObjCmd): Added length check to the old
depreceated newline syntax, to ensure that only "nonewline" is
accepted. [Bug 985869] (mistachkin)
2004-07-13 Jeff Hobbs <jeffh@ActiveState.com>
* README, generic/tcl.h, tools/tcl.wse.in: bumped to
* unix/configure, unix/configure.in, unix/tcl.spec: patchlevel
* win/README.binary, win/configure, win/configure.in: 8.4.7
2004-07-13 Zoran Vasiljevic <vasiljevic@users.sf.net>
* generic/tclEvent.c (NewThreadProc): Fixed broken build on Windows
caused by missing TCL_THREAD_CREATE_RETURN. This is backported from
HEAD. Thnx to Kevin Kenny for spotting this.
2004-07-03 Miguel Sofer <msofer@users.sf.net>
* generic/tclExecute.c (ExprRoundFunc):
* tests/expr-old.test (39.1): added support for wide integers to
round(); [Bug 908375], reported by Hemang Lavana.
2004-07-02 Jeff Hobbs <jeffh@ActiveState.com>
* generic/regcomp.c (stid): correct minor pointer size error
* generic/tclPipe.c (TclCreatePipeline): Add 2>@1 as a special
* tests/exec.test: case redir of stderr to the result output.
2004-07-02 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/fileSystem.test: new tests backported
* win/tclWin32Dll.c: compilation fix for VC++5.2
2004-06-29 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* library/safe.tcl: Make sure that the temporary variable is
local to the namespace and not inadvertently global. [Bug 981733]
2004-06-22 Zoran Vasiljevic <vasiljevic@users.sf.net>
* generic/tclEvent.c:
* generic/tclInt.h:
* unix/tclUnixNotfy.c:
* unix/tclUnixThrd.c:
* win/tclWinThrd.c: See bug report for more information about what it
does. [Bug 770053]
* tests/unixNotfy.test: rewritten to use tcltest::threadReap to
gracefully wait for the test thread to exit. Otherwise we got a race
condition with main thread exiting before the test thread. This
exposed the long-standing Tcl lib issue with resource
garbage-collection on application exit.
2004-06-21 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWin32Dll.c (DllMain, _except_dllmain_detach_handler)
(TclpCheckStackSpace, _except_checkstackspace_handler, TclWinCPUID)
(_except_TclWinCPUID_detach_handler):
* win/tclWinChan.c (Tcl_MakeFileChannel)
(_except_makefilechannel_handler):
* win/tclWinFCmd.c (DoRenameFile, _except_dorenamefile_handler)
(DoCopyFile, _except_docopyfile_handler):
Rework pushing of exception handler function pointer so that compiling
with gcc -O3 works. Remove empty function call to avoid compiler
warning. Mark the DllMain function as noinline to avoid compiler error
from duplicated asm labels in generated code.
2004-06-14 Pat Thoyts <patthoyts@users.sourceforge.net>
* tests/winDde.test: Fixed -async test
* win/tclWinDde.c: Backported the fix from 8.5 to avoid hanging in the
presence of applications that do not process Window messages.
2004-06-10 Andreas Kupries <andreask@activestate.com>
* generic/tclDecls.h: Regenerated on a unix box. The Win/DOS
* generic/tclIntDecls.h: EOLs from the last regen screwed up
* generic/tclIntPlatDecls.h: compilation with an older gcc.
* generic/tclPlatDecls.h:
* generic/tclStubInit.c:
2004-06-10 Zoran Vasiljevic <vasiljevic@users.sf.net>
* generic/tclIOUtil.c: partially corrected [Bug 932314]. Also,
corrected return values of Tcl_FSChdir() to reflect those of the
underlying platform-specific call. Originally, return codes were mixed
with those of Tcl.
2004-06-08 Miguel Sofer <msofer@users.sf.net>
* generic/tclCompile.c: handle warning [Bug 969066]
2004-06-05 Kevin B. Kenny <kennykb@acm.org>
* generic/tcl.h: Corrected Tcl_WideInt declarations so that the mingw
build works again.
* generic/tclDecls.h: Changes to the tests for
* generic/tclInt.decls: clock frequency in Tcl_WinTime
* generic/tclIntDecls.h: so that any clock frequency is
* generic/tclIntPlatDecls.h: accepted provided that all
* generic/tclPlatDecls.h: CPU's in the system share a
* generic/tclStubInit.c: common chip, and hence,
* tests/platform.test (platform-1.3): presumably, a common clock.
* win/tclWin32Dll.c (TclWinCPUID): This change necessitated a
* win/tclWinTest.c (TestwincpuidCmd) small burst of assembly code
* win/tclWinTime.c (Tcl_GetTime): to read CPU ID information,
which was added as TclWinCPUID in the internal Stubs. To test this
code in the common case of a single-processor machine, a
'testwincpuid' command was added to tclWinTest.c, and a test case in
platform.test. Thanks to Jeff Godfrey and Richard Suchenwirth for
reporting this bug. [Bug 976722]
2004-05-27 Kevin B. Kenny <kennykb@acm.org>
* tests/clock.test: Added a single test for the presence of %G in
[clock format], and conditioned out the clock-10.x series if they're
all going to fail because of a broken strftime() call. [Bug 961714]
2004-05-27 Reinhard Max <max@suse.de>
* generic/tclEncoding.c:
* tests/encoding.test: added support and tests for translating
embedded null characters between real nullbytes and the internal
representation on input/output. [Bug 949905]
2004-05-26 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Correction to debug prints and testing
* library/tcltest/pkgIndex.tcl: if TCLTEST_OPTIONS value. Corrected
* tests/tcltest.test: double increment of numTestFiles in
-singleproc 1 configurations. Updated tcltest-19.1 to tcltest 2.1
behavior. Corrected tcltest-25.3 to not falsely report a failure in
tcltest.test. Bumped to tcltest 2.2.6. [Bugs 960560, 960926]
2004-05-25 Jeff Hobbs <jeffh@ActiveState.com>
* doc/http.n (http::config): add -urlencoding option (default utf-8)
* library/http/http.tcl: that specifies encoding conversion of
* library/http/pkgIndex.tcl: args for http::formatQuery. Previously
* tests/http.test: undefined, RFC 2718 says it should be
utf-8. 'http::config -urlencoding {}' returns previous behavior,
which will throw errors processing non-latin-1 chars. Bumped http
package to 2.5.0.
2004-05-25 Kevin Kenny <kennykb@acm.org>
* tests/winFCmd.test: Correct test for the presence of a CD-ROM so
that it doesn't misdetect some other sort of filesystem with a
write-protected root as being a CD-ROM drive. [Bug 918267]
2004-05-24 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclExecute.c (VerifyExprObjType): use GET_WIDE_OR_INT to
properly have tclIntType used for smaller values. This corrects TclX
bug 896727 and any other 3rd party extension that created math
functions but was not yet WIDE_INT aware in them.
2004-05-24 Miguel Sofer <msofer@users.sf.net>
* doc/set.n: accurate description of name resolution process,
referring to namespace.n for details [Bug 959180]
2004-05-22 Miguel Sofer <msofer@users.sf.net>
* generic/tclVar.c (TclObjUnsetVar2): backported fix [Bug 735335] and
new (in tcl8.4) exteriorisations of [Bug 736729] due to the use of
tclNsVarNameType obj types. The consequences of [Bug 736729] should be
the same as in tcl8.3 and previous versions. The use of
tclNsVarNameType objs is still disabled, pending a decision by the
release manager.
2004-05-19 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* win/tclWinFile.c (TclpMatchInDirectory): fix for an issue where
there was a sneak path from Tcl_DStringFree to SetErrorCode(0). The
result was that the error code could be reset between a call to
FindFirstFile and the check of its status return, leading to a bizarre
error return of {POSIX unknown {No error}}. (Found in unplanned test -
no incident logged at SourceForge.)
2004-05-19 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.c: Fixed [SF Tcl Bug 943274]. This is the same problem
* generic/tclIO.h: as [SF Tcl Bug 462317], see ChangeLog entry
2001-09-26. The fix done at that time is incomplete. It is possible to
get around it if the actual read operation is defered and not executed
in the event handler itself. Instead of tracking if we are in an read
caused by a synthesized fileevent we now track if the OS has delivered
a true event = actual data and bypass the driver if a read finds that
there is no actual data waiting. The flag is cleared by a short or
full read. [[this bug amended 2004-07-14]]
2004-05-18 Kevin B. Kenny <kennykb@acm.org>
* compat/strftime.c (_fmt, ISO8601Week):
* doc/clock.n:
* tests/clock.test: Major rework to the handling of ISO8601 week
numbers. Now passes all the %G and %V test cases on Windows, Linux and
Solaris [Bugs 500285, 500389, and 852944]
2004-05-17 Kevin B. Kenny <kennykb.@acm.org>
* generic/tclInt.decls: Restored TclpTime_t kludge to all places
* generic/tclIntPlatDecls.h: where it appeared before the changes of
* unix/tclUnixPort.h 14 May, because use of native time_t in
* unix/tclUnixTime.h its place requires the 8.5 header
* win/tclWinTime.h: reforms. [Bug 955146]
2004-05-17 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/OpenFileChnl.3: Documented type of 'offset' argument to Tcl_Seek
was wrong. [Bug 953374]
2004-05-14 Kevin B. Kenny <kennykb@acm.org>
* generic/tclInt.decls: Promoted TclpLocaltime and TclpGmtime
* generic/tclIntDecls.h: from Unix-specific stubs to the generic
* generic/tclIntPlatDecls.h: internal Stubs table. Reran 'genstubs'
* generic/tclStubInit.c:
* unix/tclUnixPort.h:
* generic/tclClock.c: Changed a buggy 'GMT' timezone specification to
the correct 'GMT0'. [Bug 922848]
* unix/tclUnixThrd.c: Moved TclpGmtime and TclpLocaltime to
unix/tclUnixTime.c where they belong.
* unix/tclUnixTime.c (TclpGmtime, TclpLocaltime, TclpGetTimeZone,
(ThreadSafeGMTime[removed], ThreadSafeLocalTime[removed],
(SetTZIfNecessary, CleanupMemory): Restructured to make sure that the
same mutex protects all calls to localtime, gmtime, and tzset. Added a
check in front of those calls to make sure that the TZ env var hasn't
changed since the last call to tzset, and repeat tzset if necessary.
[Bug 940278] Removed a buggy test of the Daylight Saving Time
information in 'gettimeofday' in favor of applying 'localtime' to a
known value. [Bug 922848]
* tests/clock.test (clock-3.14): Added test to make sure that changes
to $env(TZ) take effect immediately.
* win/tclWinTime.c (TclpLocaltime, TclpGmtime): Added porting layer
for 'localtime' and 'gmtime' calls.
2004-05-10 David Gravereaux <davygrvy@pobox.com>
* win/tclWinPipe.c (BuildCommandLine): Append a space when the path
got primed.
(TclpCreateProcess): When under NT, with no console, and executing a
DOS application, the path priming does not need an ending space as
BuildCommandLine() will append one for us.
2004-05-07 Miguel Sofer <msofer@users.sf.net>
* doc/unset.n: added upvar.n to the "see also" list
2004-05-05 David Gravereaux <davygrvy@pobox.com>
* generic/tclEvent.c: TclSetLibraryPath's use of caching the stringrep
of the pathPtr object to TclGetLibraryPath called from another thread
was ineffective if the original's stringrep had been invalidated as
what happens when it gets muted to a list.
* generic/tclEncoding.c: Added FreeEncoding(systemEncoding) in
TclFinalizeEncodingSubsystem because its ref count was incremented in
TclInitEncodingSubsystem.
* win/tclWin32Dll.c: Structured Exception Handling added around
Tcl_Finalize called from DllMain's DLL_PROCESS_DETACH. We can't be
100% assured that Tcl is being unloaded by the OS in a stable
condition and we need to protect the exit handlers should the stack be
in a hosed state. AT&T style assembly for SEH under MinGW included,
too. [Patch 858493]
Also added DisableThreadLibraryCalls() for the DLL_PROCESS_ATTACH
case. We're not interested in knowing about DLL_THREAD_ATTACH, so
disable the notices.
* generic/tclInt.h:
* generic/tclThread.c:
* generic/tclEvent.c:
* unix/tclUnixThrd.c:
* win/tclWinThrd.c: Provisions made so masterLock, initLock,
allocLock and joinLock mutexes can be recovered during Tcl_Finalize.
* win/tclWinSock.c:
(SocketThreadExitHandler): Don't call TerminateThread when
WaitForSingleObject returns a timeout. Tcl_Finalize called from
DllMain will pause all threads. Trust that the thread will get the
close notice at a later time if it does ever wake up before being
cleaned up by the system anyway.
(SocketEventProc): connect errors should fire both the readable and
writable handlers because this is how it works on UNIX. [Bug 794839]
* win/coffbase.txt: Added the tls extension to the list of preferred
load addresses.
2004-05-05 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test (unixInit-2.10): Test correction for Mac OSX.
Be sure to consistently compare normalized path names. Thanks to
Steven Abner (tauvan). [Bug 948177]
2004-05-05 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* doc/CrtObjCmd.3: Remove reference to Tcl_RenameCommand; there is no
such API. [Bug 848440]
2004-05-04 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIOUtil.c (Tcl_FSChdir): Work-around crash condition
* tests/winFCmd.test (winFCmd-16.12): triggered when $HOME is
volumerelative (ie 'C:').
* tests/fileName.test (filename-12.9): use C:/ instead of the first
item in file volumes - that's usually A:/, which for most will have
nothing in it.
2004-05-04 Don Porter <dgp@users.sourceforge.net>
* tests/tcltest.test: Test corrections for Mac OSX. Thanks to Steven
Abner (tauvan). [Bug 947440]
2004-05-03 Andreas Kupries <andreask@activestate.com>
Applied [SF Tcl Patch 868853], fixing a mem leak in TtySetOptionProc.
Report and Patch provided by Stuart Cassoff <stwo@users.sf.net>.
2004-05-03 Kevin Kenny <kennykb@acm.org>
* win/tclWin32Dll.c (TclpCheckStackSpace):
* tests/stack.test (stack-3.1): Fix for undetected stack overflow in
TclReExec on Windows. [Bug 947070]
2004-05-03 Don Porter <dgp@users.sourceforge.net>
* library/init.tcl: Corrected unique prefix matching of
interactive command completion in [unknown]. [Bug 946952]
2004-05-02 Miguel Sofer <msofer@users.sf.net>
* generic/tclProc.c (TclObjInvokeProc):
* tests/proc.test (proc-3.6): fix for bad quoting of multi-word proc
names in error messages [Bug 942757]
2004-04-23 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.c (Tcl_SetChannelOption): Fixed [Bug 930851]. When
changing the eofchar we have to zap the related flags to prevent them
from prematurely aborting the next read.
2004-04-07 Jeff Hobbs <jeffh@ActiveState.com>
* win/configure:
* win/configure.in: define TCL_LIB_FLAG, TCL_BUILD_LIB_SPEC,
TCL_LIB_SPEC and TCL_PACKAGE_PATH in tclConfig.sh.
2004-04-06 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test (unixInit-3.1): Default encoding on Darwin
systems is utf-8. Thanks to Steven Abner (tauvan). [Bug 928808]
2004-04-06 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* tests/cmdAH.test (cmdAH-18.2): Added constraint because
access(...,X_OK) is defined to be permitted to be meaningless when
running as root, and OSX exhibits this. [Bug 929892]
2004-04-02 Don Porter <dgp@users.sourceforge.net>
* tests/tcltest.test: Corrected constraint typos: "nonRoot" ->
"notRoot". Thanks to Steven Abner (tauvan). [Bug 928353]
2004-03-31 Don Porter <dgp@users.sourceforge.net>
* doc/msgcat.n: Clarified message catalog file encodings. [Bug 811457]
* library/msgcat/msgcat.tcl ([mcset], [ConvertLocale], [Init]):
Corrected [mcset] to be able to successfully set a translation to
the empty string. [mcset $loc $src {}] was incorrectly set the $loc
translation of $src back to $src. Also changed [ConvertLocale] to
minimally require a non-empty "language" part in the locale value. If
not, an error raised prompts [Init] to keep looking for a valid locale
value, or ultimately fall back on the "C" locale. [Bug 811461]
* library/msgcat/pkgIndex.tcl: Bump to msgcat 1.3.2.
2004-03-31 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclObj.c (HashObjKey): Make sure this hashes the whole
string rep of the object, instead of missing the last character.
2004-03-29 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclInt.h:
* generic/tclEncoding.c (TclFindEncodings, Tcl_FindExecutable):
* mac/tclMacInit.c (TclpInitLibraryPath): Correct handling of UTF
* unix/tclUnixInit.c (TclpInitLibraryPath): data that is actually
* win/tclWinFile.c (TclpFindExecutable): "clean", allowing the
* win/tclWinInit.c (TclpInitLibraryPath): loading of Tcl from paths
that contain multi-byte chars on Windows [Bug 920667]
2004-03-28 Miguel Sofer <msofer@users.sf.net>
* generic/tclCompile.c (TclCompileScript): corrected possible segfault
when a compilation returns TCL_OUTLINE_COMPILE after having grown the
compile environment. [Bug 925121]
2004-03-21 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinInt.h: define VER_PLATFORM_WIN32_CE if not already set.
* win/tclWinInit.c (TclpSetInitialEncodings): recognize WIN32_CE
as a unicode (WCHAR) platform.
2004-03-15 Miguel Sofer <msofer@users.sf.net>
* generic/tclCompile.c (TclCompileScript):
* tests/compile.test (compile-3.5): corrected wrong test and behaviour
in the earlier fix for [Bug 705406]; Don Porter reported this as [Bug
735055], and provided the solution. Fixed in HEAD on 2003-05-09, but
backport to 8-4-branch was wrongly omitted; re-reported as [Bug
916795] by Roy Terry, diagnosed by dgp.
2004-03-08 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFileName.c: Fix to 'glob -path' near the root
* tests/fileName.test: of the filesystem. [Bug 910525]
2004-03-01 Don Porter <dgp@users.sourceforge.net>
*** 8.4.6 TAGGED FOR RELEASE ***
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Allow 64-bit enabling on
IRIX64-6.5* systems. [Bug 218561]
* unix/configure: autoconf-2.13
* generic/tclCmdMZ.c (TclCheckInterpTraces): The TIP 62
* generic/tclTest.c (TestcmdtraceCmd): implementation introduced a
* tests/basic.test (basic-39.10): bug by testing the CallFrame
level instead of the iPtr->numLevels level when deciding what traces
created by Tcl_Create(Obj)Trace to call. Added test to expose the
error, and made fix. [Request 462580]
2004-02-26 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: fixed copyright year in Tcl.framework Info.plist
2004-02-25 Don Porter <dgp@users.sourceforge.net>
* tests/basic.test: Made several tests more robust to the
* tests/cmdMZ.test: list-quoting of path names that might
* tests/exec.test: contain Tcl-special chars like { or [.
* tests/io.test: Should help us sort out Tcl Bug 554068.
* tests/pid.test:
* tests/socket.test:
* tests/source.test:
* tests/unixInit.test:
2004-02-25 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tclUnixChan.c (TcpGetOptionProc): Stop memory leak with very
long hostnames. [Bug 888777]
2004-02-25 David Gravereaux <davygrvy@pobox.com>
* tests/winPipe.test:
* win/tclWinPipe.c: backport of BuildCommandLine changes to mirror
msvcrt's parse_cmdline() rules of quoting.
2004-02-19 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWinInit.c (AppendEnvironment): Use the tail component of the
passed in lib path instead of just blindly using lib+4. That worked
when lib was "lib/..." but fails for other values. Thanks go to
Patrick Samson for pointing this out.
2004-02-17 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n:
* library/tcltest/tcltest.tcl: Changed -verbose default value to
{body error} so that detailed information on unexpected errors in
tests is provided by default, even after the fix for [Bug 725253]
2004-02-17 Jeff Hobbs <jeffh@ActiveState.com>
(reverted due to test failures on Solaris, but not Win/Lin :/)
* generic/tclIOUtil.c: backport of rewrite of generic file
normalization code to cope with links followed by '..'. [Bug 849514],
and parts of [859251]
* tests/unixInit.test: unixInit-7.1
* unix/tclUnixInit.c (TclpInitPlatform): ensure the std fds exist to
prevent crash condition [Bug 772288]
2004-02-16 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclCmdMZ.c (TclTraceExecutionObjCmd)
(TclTraceCommandObjCmd): fix possible mem leak in trace info.
2004-02-12 Jeff Hobbs <jeffh@ActiveState.com>
* README: update patchlevel to 8.4.6
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure, unix/configure.in, unix/tcl.spec:
* win/README.binary, win/configure, win/configure.in:
* unix/tcl.m4: update HP-11 build libs setup
2004-02-06 Don Porter <dgp@users.sourceforge.net>
* doc/clock.n: Removed reference to non-existent [file ctime].
2004-02-04 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Corrected references to
non-existent $name variable in [cleanupTests]. [Bug 833637]
2004-02-03 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Corrected parsing of single
command line argument (option with missing value) [Bug 833910]
* library/tcltest/pkgIndex.tcl: Bump to version 2.2.5.
2004-02-02 David Gravereaux <davygrvy@pobox.com>
* generic/tclIO.c (Tcl_Ungets): fixes improper filling of the channel
buffer. [Bug 405995]
2004-01-13 Don Porter <dgp@users.sourceforge.net>
* generic/tclFileName.c (Tcl_GlobObjCmd): Latest changes to
management of the interp result by Tcl_GetIndexFromObj() exposed
improper interp result management in the [glob] command procedure.
Corrected by adopting the Tcl_SetObjResult(Tcl_NewStringObj) pattern.
This stopped a segfault in test filename-11.36.
2004-01-13 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct, Tcl_WrongNumArgs):
Create fresh objects instead of using the one currently in the
interpreter, which isn't guaranteed to be fresh and unshared. The
cost for the core will be minimal because of the object cache, and
this fixes. [Bug 875395]
2004-01-09 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c: fix to infinite loop in TclFinalizeFilesystem.
[Bug 873311]
2003-12-17 Daniel Steffen <das@users.sourceforge.net>
* generic/tclBinary.c (DeleteScanNumberCache): fixed crashing bug when
numeric scan-value cache contains NULL value.
2003-12-17 Zoran Vasiljevic <zv@archiware.com>
* generic/tclIOUtil.c: fixed 2 memory (object) leaks. This fixes [Bug
839519]
2003-12-12 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclCmdAH.c: fix to normalization of non-existent user name
('file normalize ~nobody') [Bug 858937]
2003-12-09 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* unix/tclUnixPort.h: #ifdef'd out declarations of errno which
* tools/man2tcl.c: are known to cause problems with recent
glibc. [Bug 852369]
2003-12-03 Don Porter <dgp@users.sourceforge.net>
* generic/tcl.h: Bumped patch level to 8.4.5.1 to distinguish
* unix/configure.in: CVS snapshots from 8.4.5 release.
* unix/tcl.spec:
* win/configure.in:
* unix/configure: autoconf (2.13)
* win/configure:
2003-12-02 Donal K. Fellows <donal.k.fellows@man.ac.uk>
* generic/tclBinary.c (DeleteScanNumberCache, ScanNumber): Made
the numeric scan-value cache have proper references to the objects
within it so strange patterns of writes won't cause references to
freed objects. Thanks to Paul Obermeier for the report. [Bug 851747]
2003-12-01 Miguel Sofer <msofer@users.sf.net>
* doc/lset.n: fix typo [Bug 852224]
2003-11-21 Don Porter <dgp@users.sourceforge.net>
*** 8.4.5 TAGGED FOR RELEASE ***
* tests/windFCmd.test (winFCmd-16.10): Corrected failure to
initialize variable $dd that caused test suite failure.
2003-11-20 Miguel Sofer <msofer@users.sf.net>
* generic/tclVar.c: fix flag bit collision between LOOKUP_FOR_UPVAR
and TCL_PARSE_PART1 (deprecated) [Bug 835020]
2003-11-20 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c:
* tests/winFCmd.test: fix to [Bug 845778] - Infinite recursion on [cd]
(Windows only bug).
2003-11-18 Jeff Hobbs <jeffh@ActiveState.com>
* changes: updated for 8.4.5 release
2003-11-17 Don Porter <dgp@users.sourceforge.net>
* generic/regcomp.c: Backported regexp bug fixes and tests. Thanks
* generic/tclTest.c: to Pavel Goran and Vince Darley.
* tests/reg.test: [Bugs 230589, 504785, 505048, 703709, 840258]
2003-11-12 Jeff Hobbs <jeffh@ActiveState.com>
* tests/cmdMZ.test (cmdMZ-1.4): change to nonPortable as more
systems are using permissions caching, and this isn't really a Tcl
controlled issue.
2003-11-11 Jeff Hobbs <jeffh@ActiveState.com>
* unix/configure:
* unix/tcl.m4: improve AIX --enable-64bit handling
2003-11-10 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test (unixInit-2.10): re-enabled.
* unix/tclUnixInit.c (TclpInitLibraryPath): Alternative fix
* win/tclWinInit.c (TclpInitLibraryPath): for [Bug 832657]
that should not run afoul of startup constraints.
* library/dde/pkgIndex.tcl: Added safeguards so that registry
* library/reg/pkgIndex.tcl: and dde packages are not offered
* win/tclWinDde.c: on non-Windows platforms. Bumped to
* win/tclWinReg.c: registry 1.1.3 and dde 1.2.2.
2003-11-06 Jeff Hobbs <jeffh@ActiveState.com>
* tests/unixInit.test (unixInit-2.10): mark as knownBug
* generic/tclEncoding.c (TclFindEncodings): revert patch from
2003-11-05. It wasn't valid in the sensitive startup init phase
and broke Windows from working at all.
2003-11-07 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: optimized builds define NDEBUG to turn off
ThreadAlloc range checking.
2003-11-05 Don Porter <dgp@users.sourceforge.net>
* generic/tclEncoding.c (TclFindEncodings): Normalize the path
of the executable before passing to TclpInitLibraryPath() to avoid
buggy handling of paths containing "..". [Bug 832657]
* tests/unixInit.test (unixInit-2.10): New test for fixed bug.
2003-11-04 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: added 'test' target.
2003-10-31 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclTest.c: fix test suite memory leak (backport error)
* unix/tclUnixFile.c: ensure translated path (required for correct
error messages) is freed in both code paths.
2003-10-23 Andreas Kupries <andreask@activestate.com>
* unix/tclUnixChan.c (Tcl_MakeFileChannel): Applied [Patch 813606]
fixing [Bug 813087]. Detection of sockets was off for Mac OS X which
implements pipes as local sockets. The new code ensures that only IP
sockets are detected as such.
2003-10-22 Andreas Kupries <andreask@activestate.com>
* win/tclWinSock.c (TcpWatchProc): Watch for FD_CLOSE too when asked
for writable events by the generic layer.
(SocketEventProc): Generate a writable event too when a close is
detected.
Together the changes fix [Bug 599468].
2003-10-22 Andreas Kupries <andreask@activestate.com>
* generic/tclIOUtil.c (FsListMounts, FsAddMountsToGlobResult): New
functions. See below for context.
(Tcl_FSMatchInDirectory): Modified to call on the new functions
(above) to handle the mountpoints in the glob'bed directory correctly.
Part of the patch by Vincent Darley to solve the [Bug 800106] for the
8.4.x series.
* generic/tcl.h (TCL_GLOB_TYPE_MOUNT): New definition. Part of the
patch by Vincent Darley to solve [Bug 800106] for the 8.4.x series.
2003-10-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdAH.c (Tcl_FileObjCmd): Changed FILE_ prefix for option
enumeration to FCMD_ to prevent collision with symbols defined by
Cygwin/Mingw32 on NT. [Bug 822528]
2003-10-21 Daniel Steffen <das@users.sourceforge.net>
* tools/tcltk-man2html.tcl: fixed incorrect html generated for .IP/.TP
lists, now use <DL><DT>...<DD>...<P><DT>...<DD>...</DL> instead of
illegal <DL><P><DT>...<DD>...<P><DT>...<DD>...</DL>. Added skipping of
directives directly after .TP to avoid them being used as item
descriptions, e.g. .TP\n.VS in clock.n.
2003-10-21 Andreas Kupries <andreask@activestate.com>
* win/tclWinPipe.c (BuildCommandLine): Applied the patch coming with
[Bug 805605] to the code, fixing the incorrect use of ispace noted by
Ronald Dauster <ronaldd@users.sourceforge.net>.
2003-10-14 David Gravereaux <davygrvy@pobox.com>
* win/tclAppInit.c (sigHandler): Punt gracefully if exitToken has
already been destroyed.
2003-10-13 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclCmdMZ.c:
* tests/regexp.test: fix to [Bug 823524] in regsub; added three new
tests.
2003-10-12 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixTest.c (TestalarmCmd): don't bother checking return
value of alarm. [Bug 664755] (english)
2003-10-08 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c: Save and restore the iPtr->flag bits that
control the state of errorCode and errorInfo management when calling
"leave" execution traces, so that all error information of the traced
command is still available whether traced or not. Thanks to Yahalom
Emet. [Bug 760947]
2003-10-08 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclTest.c (TestNumUtfCharsCmd): Command to allow finer
access to Tcl_NumUtfChars for testing.
* generic/tclUtf.c (Tcl_NumUtfChars): Corrected string length
determining when the length parameter is negative; the terminator is a
zero byte, not (necessarily) a \u0000 character. [Bug 769812]
2003-10-07 Don Porter <dgp@users.sourceforge.net>
* tests/exec.test: Corrected temporary file management
* tests/fileSystem.test: issues uncovered by -debug 1 test
* tests/io.test: operations. Also backported some
* tests/ioCmd.test: other fixes from the HEAD.
* tests/pid.test: [Bugs 675605, 675655, 675659]
* tests/socket.test:
* tests/source.test:
* tests/fCmd.test: Run tests with the [temporaryDirectory] as
the current directory, so that tests can depend on ability to write
files. [Bug 575837]
* doc/OpenFileChnl.3: Updated Tcl_Tell and Tcl_Seek documentation
to reflect that they now return Tcl_WideInt (TIP 72) [Bug 787537]
* tests/io.test: Corrected several tests that failed when paths
* tests/ioCmd.test: included regexp-special chars. [Bug 775394]
2003-10-06 Don Porter <dgp@users.sourceforge.net>
* tests/regexp.test: Matched [makeFile] with [removeFile].
* tests/regexpComp.test: [Bug 675652]
* tests/fCmd.test (fCmd-8.2): Test only that tilde-substitution
happens, not for any particular result. [Bug 685991]
* unix/tcl.m4 (SC_PATH_TCLCONFIG): Corrected search path so
that alpha and beta releases of Tcl are not favored. [Bug 608698]
* tests/reg.test: Corrected duplicate test names.
* tests/resource.test: [Bugs 710370, 710358]
* tests/cmdMZ.test: Updated [package require tcltest] lines to
* tests/fileSystem.test: indiciate that these test files
* tests/notify.test: use features of tcltest 2. [Bug 706114]
* tests/parseExpr.test:
* tests/unixNotfy.test:
2003-10-06 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFileName.c:
* generic/tclIOUtil.c: backport of volumerelative file normalization
and 'file join' inconsistency fixes [Bug 767834, 813273].
2003-10-04 Chengye Mao <chengye.geo@yahoo.com>
* win/tclWinPipe.c: fixed a bug in BuildCommandLine.
This bug built a command line with a missing space between
tclpipe.dll and the following arguments. It caused error
in Windows 98 when exec command.com (e.g. dir) [Bug 789040]
2003-10-03 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c: Fixed error in ref count management of command
* generic/tclCmdMZ.c: and execution traces that caused access to
freed memory in trace-32.1. [Bug 811483]
2003-10-03 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/fileName.test:
* tests/winFCmd.test:
* doc/FileSystem.3: backported various test and documentation changes
from HEAD. Backport of actual code fixes to follow.
2003-10-02 Don Porter <dgp@users.sourceforge.net>
* README: Bumped patch level to 8.4.5 to prepare
* generic/tcl.h: for next patch release.
* tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure.in:
* unix/configure: autoconf (2.13)
* win/configure:
* library/http/http.tcl: Bumped to http 2.4.5
* library/http/pkgIndex.tcl:
2003-10-01 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: fixed redo prebinding bug when DESTDIR="".
* mac/tclMacResource.c: fixed possible NULL dereference (bdesgraupes).
2003-09-29 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c (CallCommandTraces): Added safety bit
* tests/trace.test: masking to prevent any of the bit values
TCL_TRACE_*_EXEC from leaking into the flags field of any Command
struct. This does not fix [Bug 811483] but helps to contain some of
its worst symptoms. Also backported the corrections to test trace-28.4
from Vince Darley.
2003-09-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* library/http/http.tcl (geturl): Correctly check the type of
boolean-valued options. [Bug 811170]
* unix/tcl.m4 (SC_ENABLE_FRAMEWORK): Added note to make it clearer
that this is an OSX feature, not a general Unix feature. [Bug 619440]
2003-09-28 David Gravereaux <davygrvy@pobox.com>
* win/tclWinPipe.c: The windows port of expect can call
TclWinAddProcess before any of the other pipe functions. Added a
missing PipeInit() call to make sure the initialization happens.
2003-09-25 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: ensure SYMROOT exists if OBJROOT is overridden on
command line. Replaced explict use of /usr/bin by ${BINDIR}.
2003-09-23 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdMZ.c: Fixed [Bug 807243] where
* tests/trace.test (trace-31,32.*): the introspection results
of both [trace info command] and [trace info execution] were getting
co-mingled. Thanks to Mark Saye for the report.
* library/init.tcl (auto_load, auto_import): Expanded Eric Melski's
2000-01-28 fix for [Bug 218871] to all potentially troubled uses of
[info commands] on input data, where glob-special characters could
cause problems.
2003-09-19 Miguel Sofer <msofer@users.sf.net>
* generic/tclExecute.c: adding (DE)CACHE_STACK_INFO() pairs to protect
all calls that may cause traces on ::errorInfo or ::errorCode to
corrupt the stack [Bug 804681]
2003-09-10 Don Porter <dgp@users.sourceforge.net>
* library/opt/optparse.tcl: Overlooked dependence of opt 0.4.4
* library/opt/pkgIndex.tcl: on Tcl 8.2. Bumped to opt 0.4.4.1.
2003-09-01 Zoran Vasiljevic <zoran@archiware.com>
* generic/tclIOUtil.c: backported fix from HEAD [Bug 788780]
2003-08-27 Don Porter <dgp@users.sourceforge.net>
* generic/tclUtil.c: Corrected [Bug 411825] and other bugs in
TclNeedSpace() where non-breaking space (\u00A0) and backslash-escaped
spaces were handled incorrectly.
* tests/util.test: Added new tests util-8.[2-6].
2003-08-06 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinInit.c: recognize amd64 and ia32_on_win64 cpus and
Windows CE platform.
2003-08-06 Don Porter <dgp@users.sourceforge.net>
* library/msgcat/msgcat.tcl: Added escape so that non-Windows
* library/msgcat/pkgIndex.tcl: platforms do not try to use the
registry package. This can save a costly and pointless package
search. Bumped to 1.3.1. Thanks to Dave Bodenstab. [Bug 781609]
2003-08-05 Miguel Sofer <msofer@users.sf.net>
* generic/tclExecute.c (INST_INVOKE, INST_EVAL, INST_PUSH_RESULT):
added a Tcl_ResetResult(interp) at each point where the interp's
result is pushed onto the stack, to avoid keeping an extra reference
that may cause costly Tcl_Obj duplication. Detected by Franco Violi,
analyzed by Peter Spjuth and Donal Fellows. [Bug 781585]
2003-07-24 Reinhard Max <max@suse.de>
* library/package.tcl: Fixed a typo that broke pkg_mkIndex -verbose.
* tests/pkgMkIndex.test: Added a test for [pkg_mkIndex -verbose].
2003-07-23 Daniel Steffen <das@users.sourceforge.net>
* unix/Makefile.in: changes to html-tcl & html-tk targets for
compatibility with non-gnu makes.
* unix/Makefile.in: added macosx/README to dist target.
2003-07-23 Pat Thoyts <patthoyts@users.sourceforge.net>
* win/tclWinReg.c (OpenSubKey): Backported fix for [Bug 775976] which
causes the registry set command to fail when built with VC7.
* library/reg/pkgIndex.tcl: Incremented the version to 1.1.2.
2003-07-21 Jeff Hobbs <jeffh@ActiveState.com>
*** 8.4.4 TAGGED FOR RELEASE ***
* changes: updated for 8.4.4 release
2003-07-18 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: added option to allow installing manpages in
addition to default html help.
2003-07-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/Utf.3: Tightened up documentation of Tcl_UtfNext and Tcl_UtfPrev
to better match the behaviour. [Bug 769895]
2003-07-18 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIOUtil.c: correct MT-safety issues with filesystem
records. [Bug 753315] (vasiljevic)
* library/http/pkgIndex.tcl: merged to v2.4.4 from head
* library/http/http.tcl: add support for user:pass info in URL.
* tests/http.test: [Bug 759888] (shiobara)
2003-07-18 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c: Corrected several instances of unsafe
* generic/tclCompile.c: truncation of UTF-8 strings that might break
* generic/tclProc.c: apart a multi-byte character. [Bug 760872]
* library/init.tcl:
* tests/init.test:
* doc/tcltest.n: Restored the [Eval] proc to replace
* library/tcltest/tcltest.tcl: the [::puts] command when either the
-output or -error option for [test] is in use, in order to capture
data written to the output or error channels for comparison against
what is expected. This is easier to document and agrees better with
most user expectations than the previous attempt to replace [puts]
only in the caller's namespace. Documentation made more precise on the
subject. [Bug 706359]
* doc/AddErrInfo.3: Improved consistency of documentation by using
* doc/CrtTrace.3: "null" everywhere to refer to the character
* doc/Encoding.3: '\0', and using "NULL" everywhere to refer to
* doc/Eval.3: the value of a pointer that points to nowhere.
* doc/GetIndex.3: Also dropped references to ASCII that are no
* doc/Hash.3: longer true, and standardized on the
* doc/LinkVar.3: hyphenated spelling of "null-terminated".
* doc/Macintosh.3:
* doc/OpenFileChnl.3:
* doc/SetVar.3:
* doc/StringObj.3:
* doc/Utf.3:
* doc/CrtSlave.3 (Tcl_MakeSafe): Removed warning about possible
deprecation (no TIP on that).
2003-07-17 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: added var to allow overriding of tclsh used during
html help building (Landon Fuller).
2003-07-16 Mumit Khan <khan@nanotech.wisc.edu>
* generic/tclIOUtil.c (SetFsPathFromAny): Add Cygwin specific code to
convert POSIX filename to native format.
* generic/tclFileName.c (Tcl_TranslateFileName): And remove from here.
(TclDoGlob): Adjust for cygwin and append / for dirs instead of \
* win/tclWinFile.c (TclpObjChdir): Use chdir on Cygwin. [Patch 679315]
2003-07-16 Jeff Hobbs <jeffh@ActiveState.com>
* library/safe.tcl (FileInAccessPath): normalize paths before
comparison. [Bug 759607] (myers)
* unix/tclUnixNotfy.c (NotifierThreadProc): correct size of found and
word vars from int to long. [Bug 767578] (hgo)
2003-07-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/CrtSlave.3 (Tcl_MakeSafe): Updated documentation to strongly
discourage use. IMHO code outside the core that uses this function is
a bug... [Bug 655300]
2003-07-16 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tcl.h: Add recognition of -DTCL_UTF_MAX=6 on the
* generic/regcustom.h: make line to support UCS-4 mode. No config arg
at this time, as it is not the recommended build mode.
* generic/tclPreserve.c: In Result and Preserve'd routines, do not
* generic/tclUtil.c: assume that ckfree == free, as that is not
* generic/tclResult.c: always true. [Bug 756791] (fuller)
2003-07-16 Mo DeJong <mdejong@users.sourceforge.net>
* win/Makefile.in: Don't define TCL_DBGX symbol for every compile.
Instead, define TCL_PIPE_DLL only when compiling tclWinPipe.c. This
will break other build systems, so they will need to remove the
TCL_DBGX define and replace it with a define for TCL_PIPE_DLL.
* win/makefile.vc: Ditto.
* win/tclWinPipe.c (TclpCreateProcess): Remove PREFIX_IDENT and
DEBUG_IDENT from top of file. Use TCL_PIPE_DLL passed in from build
env instead of trying to construct the dll name from already defined
symbols. This approach is more flexible and better in the long run.
2003-07-16 Don Porter <dgp@users.sourceforge.net>
* generic/tclFileName.c (Tcl_GlobObjCmd): [Bug 771840]
* generic/tclIOUtil.c (Tcl_FSConvertToPathType):[Bug 771947]
* unix/tclUnixFCmd.c (GetModeFromPermString): [Bug 771949]
Silence compiler warnings about unreached lines.
* library/tcltest/tcltest.tcl (ProcessFlags): Corrected broken call
* library/tcltest/pkgIndex.tcl: to [lrange]. Bumped to
version 2.2.4. [Bug 772333]
2003-07-15 Mo DeJong <mdejong@users.sourceforge.net>
* unix/dltest/pkga.c (Pkga_EqObjCmd): Fix typo that was causing a
crash in load.test.
2003-07-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/array.n: Added some examples from David Welton [Patch 763312]
2003-07-15 Don Porter <dgp@users.sourceforge.net>
* doc/http.n: Updated SYNOPSIS to match actual syntax of commands.
[Bug 756112]
* unix/dltest/pkga.c: Updated to not use Tcl_UtfNcmp and counted
strings instead of strcmp (not defined in any #include'd header) and
presumed NULL-terminated strings.
* README: Bumped patch level to 8.4.4 in anticipation
* generic/tcl.h: of another patch release.
* tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure.in:
* unix/configure: autoconf (2.13)
* win/configure:
* generic/tclCompCmds.c (TclCompileIfCmd): Prior fix of Bug 711371
on 2003-04-07 introduced a buffer overflow. Corrected. [Bug 771613]
2003-07-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdIL.c (SortCompare): Cleared up confusing error
message. [Bug 771539]
2003-07-15 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: Rewrote buildsystem for Mac OS X framework build to
be purely make driven; in order to become independent of Apple's
closed-source IDE and build tool. The changes are intended to be
transparent to the Makefile user, all existing make targets and cmd
line variable overrides should continue to work. Changed build to only
include tcl specific html help in Tcl.framework, the tk specific html
help is now included in Tk.framework.
* macosx/Tcl.pbproj/project.pbxproj:
* macosx/Tcl.pbproj/jingham.pbxuser: Changed to purely call through to
the make driven buildsystem; Tcl.framework is no longer assembled by
ProjectBuilder. Set default SYMROOT in target options to simplify
setting up PB (manually setting common build folder for tcl & tk no
longer needed).
* tools/tcltk-man2html.tcl: Added options to allow building only the
tcl or tk html help files; the default behaviour with none of the new
options is to build both, as before.
* unix/Makefile.in: Added targets for building only the tcl or tk help.
* macosx/README (new): Tcl specific excerpts of tk/macosx/README.
* generic/tcl.h: Updated reminder comment about editing
macosx/Tcl.pbproj/project.pbxproj when version number changes.
2003-07-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/binary.test (binary-46.*): Tests to help enforce the current
behaviour.
* doc/binary.n: Documented that [binary format a] and [binary scan a]
do encoding conversion by dropping high bytes, unlike the rest of
the core. [Bug 735364]
2003-07-11 Don Porter <dgp@users.sourceforge.net>
* library/package.tcl: Corrected [pkg_mkIndex] bug reported on
comp.lang.tcl. The indexer was searching for newly indexed packages
instead of newly provided packages.
2003-07-04 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/expr.n: Tighten up the wording of some operations. [Bug 758488]
* tests/cmdAH.test: Made tests of [file mtime] work better on FAT
filesystems. [Patch 760768] Also a little general cleanup.
2003-06-25 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Add -ieee when compiling with cc and
add -mieee when compiling with gcc under OSF1-V5 "Tru64" systems. [Bug
748957]
2003-06-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/encoding.n: Corrected the docs to say that [source] uses the
system encoding, which it always did anyway (since 8.1) [Bug 742100]
2003-06-23 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFCmd.c: fix to bad error message when trying to do 'file
copy foo ""'. [Bug 756951]
* tests/fCmd.test: added two new tests for the bug.
* doc/FileSystem.3: documentation fix [Bug 720634]
2003-06-18 Miguel Sofer <msofer@users.sf.net>
* generic/tclNamesp.c (Tcl_Export): removed erroneous comments [Bug
756744]
2003-06-17 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclCmdMZ.c:
* tests/regexp.test: fixing of bugs related to regexp and regsub
matching of empty strings. Addition of a number of new tests.
2003-06-10 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c:
* generic/tclExecute.c: let TclEvalObjvInternal call TclInterpReady
instead of relying on its callers to do so; fix for the part of [Bug
495830] that is new in 8.4.
* tests/interp.test: Added tests 18.9 (knownbug) and 18.10
2003-06-09 Don Porter <dgp@users.sourceforge.net>
* tests/string.test (string-4.15): Added test for [string first] bug
reported in Tcl 8.3, where test for all-single-byte-encoded strings
was not reliable.
2003-06-04 Joe Mistachkin <joe@mistachkin.com>
* tools/man2help.tcl: Added duplicate help section checking and
* tools/index.tcl: corrected a comment typo for the getTopics proc
in index.tcl. [Bug 748700]
2003-05-23 Don Porter <dgp@users.sourceforge.net>
* generic/tclObj.c (tclCmdNameType): Converted internal rep
management of the cmdName Tcl_ObjType the opposite way, to always use
the twoPtrValue instead of always using the otherValuePtr. Previous
fix on 2003-05-12 broke several extensions that wanted to poke around
with the twoPtrValue.ptr2 value of a cmdName Tcl_Obj, like TclBlend
and e4graph. [Bug 726018] Thanks to George Petasis for the bug report
and Jacob Levy for testing assistance.
2003-05-22 Daniel Steffen <das@users.sourceforge.net>
*** 8.4.3 TAGGED FOR RELEASE ***
* macosx/tclMacOSXBundle.c: fixed a problem that caused only the first
call to Tcl_MacOSXOpenVersionedBundleResources() for a given bundle
identifier to succeed. This caused the tcl runtime library not to be
found in all interps created after the inital one.
2003-05-20 Jeff Hobbs <jeffh@ActiveState.com>
* changes: updated for 8.4.3
* unix/Makefile.in: do not run autoconf during 'make dist' as the
configure is now a CVS-maintained file and should be up-to-date.
2003-05-19 Daniel Steffen <das@users.sourceforge.net>
* macosx/Tcl.pbproj/project.pbxproj: changed tclConfig.sh location in
versioned framework subdirectories to be identical to location in
framework toplevel; fixed stub library symbolic links to be Tcl
version specific.
2003-05-16 Daniel Steffen <das@users.sourceforge.net>
* macosx/Tcl.pbproj/project.pbxproj: updated copyright year.
2003-05-15 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinFile.c (TclpMatchInDirectory): revert glob code to r1.44
as 2003-04-14 optimizations broke Windows98 glob'ing.
* README: bumped version to 8.4.3
* generic/tcl.h:
* macosx/Tcl.pbproj/project.pbxproj:
* tools/tcl.wse.in:
* unix/configure:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure:
* win/configure.in:
* doc/socket.n: nroff font handling correction.
* library/encoding/gb2312-raw.enc (new): This is the original
gb2312.enc renamed to allow for it to still be used. This is needed by
Tk (unix) because X fonts with gb2312* charsets really do want the
original gb2312 encoding. [Bug 557030]
2003-05-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdAH.c (Tcl_FormatObjCmd): Values which can't be
anything but wide shouldn't be demoted to long. [consequence of HEAD
fixes for Bug 699060]
2003-05-14 Jeff Hobbs <jeffh@ActiveState.com>
* library/encoding/gb2312.enc: copy euc-cn.enc over original
gb2312.enc. gb2312.enc appeared to not work as expected, and most uses
of gb2312 really mean euc-cn (which may be the cause of the problem).
[Bug 557030]
* generic/tclEnv.c (TclUnsetEnv): Another putenv() copy behavior
problem repaired when compiling on windows and using microsoft's
runtime. [Bug 736421] (gravereaux)
2003-05-13 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIOUtil.c: add decl for FsThrExitProc to suppress warnings
2003-05-13 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclEvent.c (Tcl_Finalize): Removed unused variable to reduce
compiler warnings. [Bug 664745]
2003-05-13 Joe Mistachkin <joe@mistachkin.com>
* generic/tcl.decls: Changed Tcl_JoinThread parameter name from "id"
* generic/tclDecls.h: to "threadId". [Bug 732477]
* unix/tclUnixThrd.c:
* win/tclWinThrd.c:
* mac/tclMacThrd.c:
2003-05-13 Daniel Steffen <das@users.sourceforge.net>
* generic/tcl.decls:
* macosx/tclMacOSXBundle.c: added extended version of the
Tcl_MacOSXOpenBundleResources() API taking an extra version number
argument: Tcl_MacOSXOpenVersionedBundleResources(). This is needed to
be able to access bundle resources in versioned frameworks such as Tcl
and Tk, otherwise if multiple versions were installed, only the latest
version's resources could be accessed. [Bug 736774]
* unix/tclUnixInit.c (Tcl_MacOSXGetLibraryPath): use new versioned
bundle resource API to get tcl runtime library for TCL_VERSION.
[Bug 736774]
* generic/tclPlatDecls.h:
* generic/tclStubInit.c: regen.
* unix/tclUnixPort.h: worked around the issue of realpath() not being
thread-safe on Mac OS X by defining NO_REALPATH for threaded builds on
Mac OS X. [Bug 711232]
2003-05-12 Don Porter <dgp@users.sourceforge.net>
* generic/tclInterp.c: (AliasObjCmd): Added refCounting of the words
* tests/interp.test (interp-33.1): of the target of an interp
alias during its execution. Also added test. [Bug 730244].
* generic/tclBasic.c (TclInvokeObjectCommand): objv[argc] is no
longer set to NULL (Tcl_CreateObjCommand docs already say that it
should not be accessed).
* generic/tclObj.c (tclCmdNameType): Corrected variable use of the
otherValuePtr or the twoPtrValue.ptr1 fields to store a
(ResolvedCmdName *) as the internal rep. [Bug 726018].
* doc/Eval.3: Corrected prototype for Tcl_GlobalEvalObj [Bug 727622].
2003-05-12 Miguel Sofer <msofer@users.sf.net>
* generic/tclVar.c (TclObjLookupVar): [Bug 735335] temporary fix,
disabling usage of tclNsVarNameType.
* tests/var.test (var-15.1): test for [Bug 735335]
2003-05-10 Zoran Vasiljevic <zoran@archiware.com>
* unix/tclUnixThrd.c: corrected [Bug 723502]
2003-05-10 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIOUtil.c: ensure cd is thread-safe.
[Bug 710642] (vasiljevic)
* win/tclWinSerial.c (SerialCloseProc): correct mem leak on closing a
Windows serial port [Bug 718002] (schroedter)
* generic/tclCmdMZ.c (Tcl_StringObjCmd): prevent string repeat crash
when overflow sizes were given (throws error). [Bug 714106]
2003-05-09 Joe Mistachkin <joe@mistachkin.com>
* generic/tclThreadAlloc.c (TclFreeAllocCache): Fixed memory leak
caused by treating cachePtr as a TLS index [Bug 731754].
* win/tclAppInit.c (Tcl_AppInit): Fixed memory leaks caused by not
freeing the memory allocated by setargv and the async handler created
by Tcl_AppInit. An exit handler has been created that takes care of
both leaks. In addition, Tcl_AppInit now uses ckalloc instead of
Tcl_Alloc to allow for easier leak tracking and to be more consistent
with the rest of the Tcl core [Bugs 733156, 733221].
* tools/encoding/txt2enc.c (main): Fixed memory leak caused by failing
to free the memory used by the toUnicode array of strings [Bug 733221]
2003-05-05 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: The -returnCodes option to [test]
failed to recognize the symbolic name "ok" for return code 0.
2003-05-05 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclBasic.c (Tcl_HideCommand): Fixed error message grammar
and spelling.
2003-04-29 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFileName.c: fix to bug reported privately by Jeff where,
for example, 'glob -path {[tcl]} *' gets confused by the leading
special character (which is escaped internally), and instead lists
files in '/'. Bug only occurs on Windows where '\' is also a
directory separator. (Bug has been around at least since Tcl 8.3.)
* tests/fileName.test: added test for the above bug.
2003-04-25 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c: Tcl_EvalObjv() failed to honor the
TCL_EVAL_GLOBAL flag when resolving command names. Tcl_EvalEx passed a
string rep including leading whitespace and comments to
TclEvalObjvInternal().
2003-04-25 Andreas Kupries <andreask@activestate.com>
* win/tclWinThrd.c: Applied [Patch 727271]. This patch changes the
code to catch any errors returned by the windows functions handling
TLS ASAP instead of waiting to get some mysterious crash later on due
to bogus pointers. Patch provided by Joe Mistachkin.
This is a stop-gap measure to deal with the low number of ?TLS slots
provided by some of the variants of Windows (60-80).
2003-04-21 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: When the return code of a test does
not meet expectations, report that as the reason for test failure,
and do not attempt to check the test result for correctness. [Bug
725253]
2003-04-18 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclExecute.c (ExprCallMathFunc): remove incorrect
extraneous cast from Tcl_WideAsDouble.
2003-04-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/open.n: Moved serial port options from [fconfigure]
* doc/fconfigure.n: to [open] as it is up to the creator of a
channel to describe the channel's special
config options. [Bug 679010]
2003-04-16 Don Porter <dgp@users.sourceforge.net>
* generic/tcl.h Made changes so that the "wideInt" Tcl_ObjType
* generic/tclObj.c is defined on all platforms, even those where
* generic/tclPort.h TCL_WIDE_INT_IS_LONG is defined. Also made
the Tcl_Value struct have a wideValue field on all platforms. This is
a ***POTENTIAL INCOMPATIBILITY*** for TCL_WIDE_INT_IS_LONG platforms
because that struct changes size. This is the same TIP 72
incompatibility that was seen on other platforms at the 8.4.0 release,
when this change should have happened as well. [Bug 713562]
* generic/tclInt.h: New internal macros TclGetWide() and
TclGetLongFromWide() to deal with both forms of the "wideInt"
Tcl_ObjType, so that conditional TCL_WIDE_INT_IS_LONG code
is confined to the header file.
* generic/tclCmdAH.c: Replaced most coding that was conditional
* generic/tclCmdIL.c: on TCL_WIDE_INT_IS_LONG with code that
* generic/tclExecute.c: works across platforms, sometimes using
* generic/tclTest.c: the new macros above to do it.
* generic/tclUtil.c:
* generic/tclVar.c:
2003-04-17 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/socket.n: Added a paragraph to remind people to specify
their encodings when using sockets. [Bug 630621]
2003-04-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/CrtMathFnc.3: Functions also have to deal with wide ints,
but this was not documented. [Bug 709720]
2003-04-15 Kevin Kenny <kennykb@acm.org>
* win/tclWinTime.c: Corrected use of types to make compilation
compatible with VC++5.
2003-04-14 Kevin Kenny <kennykb@acm.org>
* win/tclWinFile.c: added conditionals to restore compilation on
VC++6, which was broken by recent changes.
2003-04-14 Vince Darley <vincentdarley@users.sourceforge.net>
Merged various bug fixes from current cvs head:
* tests/cmdAH.test: better fix to test suite problem if /home is a
symlink [Bug 703264]
* generic/tclIOUtil.c: fix bad error message with 'cd ""' [Bug 704917]
* win/tclWinFile.c:
* win/tclWin32Dll.c:
* win/tclWinInt.h: allow Tcl to differentiate between reparse points
which are symlinks and mounted volumes, and correctly handle the
latter. This involves some elaborate code to find the actual drive
letter (if possible) corresponding to a mounted volume. [Bug 697862]
* tests/fileSystem.test: add constraints to stop tests running in
ordinary tcl interpreter. [Bug 705675]
* generic/tclIOUtil.c: Some re-arrangement of code to bring it closer
to CVS HEAD. No functional changes.
* tests/fCmd.test:
* win/tclWinFile.c: added some filesystem optimisation to the
'glob' implementation, and some new tests.
* tests/winFile.test:
* tests/ioUtil.test:
* tests/unixFCmd.test: renumbered tests with duplicate numbers. [Bug
710361]
2003-04-12 Kevin Kenny <kennykb@acm.org>
* tests/clock.test: Renumbered test cases to avoid duplicates [Bug
710310].
* tests/winTime.test:
* win/tclWinTest.c (TestwinclockCmd, TestwinsleepCmd):
* win/tclWinTime.c (Tcl_WinTime, UpdateTimeEachSecond,
(ResetCounterSamples, AccumulateSample, SAMPLES, TimeInfo): Made
substantial changes to the phase-locked loop (replaced an IIR filter
with an FIR one) in a quest for improved loop stability (Bug not
logged at SF, but cited in private communication from Jeff Hobbs).
2003-04-11 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdMZ.c (Tcl_StringObjCmd,STR_IS_INT): Corrected
inconsistent results of [string is integer] observed on systems
where sizeof(long) != sizeof(int). [Bug 718878]
* tests/string.test: Added tests for Bug 718878.
* doc/string.n: Clarified that [string is integer] accepts
32-bit integers.
2003-04-11 Andreas Kupries <andreask@activestate.com>
* generic/tclIO.c (UpdateInterest): When dropping interest in
TCL_READABLE now dropping interest in TCL_EXCEPTION too. This fixes a
bug where Expect detects eof on a file prematurely on Solaris 2.6 and
higher. A much more complete explanation is in the code itself (40
lines of comments for a one-line change :)
2003-04-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/binary.n: Fixed typo in [binary format w] desc. [Bug 718543]
2003-04-08 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdAH.c (Tcl_ErrorObjCmd): Strings are only empty if they
have zero length, not if their first byte is zero, so fix test
guarding Tcl_AddObjErrorInfo to take this into account. [Bug reported
by Don Porter; no bug-id.]
2003-04-07 Don Porter <dgp@users.sourceforge.net>
* generic/tclCompCmds.c (TclCompileIfCmd): Corrected string limits of
arguments interpolated in error messages. [Bug 711371]
* generic/tclCmdMZ.c (TraceExecutionProc): Added missing
Tcl_DiscardResult() call to avoid memory leak.
2003-04-07 Donal K. Fellows <zzcgudf@ernie.mvc.mcc.ac.uk>
* generic/tclObj.c (tclWideIntType, TclInitObjSubsystem):
(SetBooleanFromAny): Make sure that tclWideIntType is defined and
somewhat sensible everywhere. [Bug 713562]
2003-04-02 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure: Regen.
* win/configure.in: Set stub lib flag based on new LIBFLAGSUFFIX
variable.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Set new LIBFLAGSUFFIX that works like
LIBSUFFIX, it is used when creating library names. The previous
implementation would generate -ltclstub85 instead of -ltclstub85s when
configured with --disable-shared.
2003-04-01 Don Porter <dgp@users.sourceforge.net>
* tests/README: Direct [source] of *.test files is no longer
recommended. The tests/*.test files should only be evaluated under the
control of the [runAllTests] command in tests/all.tcl.
2003-03-27 Miguel Sofer <msofer@users.sf.net>
* tests/encoding.test:
* tests/proc-old.test:
* tests/set-old.test: Altered test numers to eliminate duplicates,
[Bugs 710313, 710320, 710352]
2003-03-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/parseOld.test: Altered test numers to eliminate duplicates.
* tests/parse.test: [Bugs 710365, 710369]
* tests/expr-old.test:
* tests/expr.test:
* tests/utf.test: Altered test numers to eliminate duplicates.
* tests/trace.test: [Bugs 710322, 710327, 710349, 710363]
* tests/lsearch.test:
* tests/list.test:
* tests/info.test:
* tests/incr-old.test:
* tests/if-old.test:
* tests/format.test:
* tests/foreach.test:
2003-03-26 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n:
* library/tcltest/tcltest.tcl: Added reporting during [configure
-debug 1] operations to warn about multiple uses of the same test
name. [FR 576693] Replaced [regexp] and [regsub] with [string map]
where possible. Thanks to David Welton. [Bugs 667456,667558]
* library/tcltest/pkgIndex.tcl: Bumped to tcltest 2.2.3
* tests/msgcat.test (msgcat-2.2.1): changed test name to avoid
duplication. [Bug 710356]
* unix/dltest/pkg?.c: Changed all Tcl_InitStubs calls to pass argument
exact = 0, so that rebuilds are not required when Tcl bumps to a new
version. [Bug 701926]
2003-03-24 Miguel Sofer <msofer@users.sf.net>
* generic/tclVar.c:
* tests/var.test: fixing ObjMakeUpvar's lookup algorithm for the
created local variable, [Bugs 631741] (Chris Darroch) and [696893]
(David Hilker).
2003-03-22 Kevin Kenny <kennykb@acm.org>
* library/dde/pkgIndex.tcl:
* library/reg/pkgIndex.tcl: Fixed a bug where [package require dde] or
[package require registry] attempted to load the release version of
the DLL into a debug build. [Bug 708218] Thanks to Joe Mistachkin for
the patch.
* win/makefile.vc: Added quoting around the script name in the 'test'
target; Joe Mistachkin insists that he has a configuration that fails
to launch tcltest without it, and it appears harmless otherwise.
2003-03-20 Don Porter <dgp@users.sourceforge.net>
* generic/tclInt.h (tclOriginalNotifier):
* generic/tclStubInit.c (tclOriginalNotifier):
* mac/tclMacNotify.c (Tcl_SetTimer,Tcl_WaitForEvent):
* unix/tclUnixNotfy.c (Tcl_SetTimer,Tcl_WaitForEvent,
(Tcl_CreateFileHandler,Tcl_DeleteFileHandler):
* win/tclWinNotify.c (Tcl_SetTimer,Tcl_WaitForEvent): Some linkers
apparently use a different representation for a pointer to a function
within the same compilation unit and a pointer to a function in a
different compilation unit. This causes checks like those in the
original notifier procedures to fall into infinite loops. The fix is
to store pointers to the original notifier procedures in a struct
defined in the same compilation unit as the stubs tables, and compare
against those values. [Bug 707174]
* generic/tclInt.h: Removed definition of ParseValue struct that is no
longer used.
2003-03-19 Miguel Sofer <msofer@users.sf.net>
* generic/tclCompile.c:
* tests/compile.test: bad command count on TCL_OUT_LINE_COMPILE
[Bug 705406] (Don Porter).
2003-03-19 Don Porter <dgp@users.sourceforge.net>
* doc/Eval.3 (Tcl_EvalObjEx): Corrected CONST and
* doc/ParseCmd.3 (Tcl_EvalTokensStandard): return type errors in
documentation. [Bug 683994]
2003-03-18 Kevin Kenny <kennykb@users.sourceforge.net>
* tests/registry.test: Changed the conditionals to avoid an abort if
[testlocale] is missing, as when running the test in tclsh rather than
tcltest. [Bug 705677]
2003-03-18 Daniel Steffen <das@users.sourceforge.net>
* tools/tcltk-man2html.tcl: added support for building 'make html'
from inside distribution directories named with 8.x.x version numbers.
tcltk-man2html now uses the latest tcl8.x.x resp. tk8.x.x directories
found inside its --srcdir argument.
2003-03-18 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/cmdAH.test: fix test suite problem if /home is a symlink
* generic/tclIOUtil.c: fix bad error message with 'cd ""'
* win/tclWinFile.c: allow Tcl to differentiate between reparse points
which are symlinks and mounted drives.
These changes fix [Bugs 703264, 704917, 697862] respectively.
2003-03-17 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/lsearch.n: Altered documentation of -ascii options so
* doc/lsort.n: they don't specify that they operate on
ASCII strings, which they never did
anyway. [Bug 703807]
2003-03-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdAH.c (Tcl_FileObjCmd): Remove assumption that file
times and longs are the same size. [Bug 698146]
(Tcl_FormatObjCmd): Stop surprising type conversions from
happening when working with integer and wide values. [Bug 699060]
* generic/tclCmdAH.c (Tcl_FormatObjCmd): Only add the modifier that
indicates we've got a wide int when we're formatting in an integer
style. Stops some libc's from going mad. [Bug 702622]
Also tidied whitespace.
2003-03-13 Kevin Kenny <kennykb@users.sourceforge.net>
* win/makefile.vc: Backed the version to 8.4 on the 8.4 branch. (I
just loathe sticky tags).
2003-03-12 Don Porter <dgp@users.sourceforge.net>
* generic/tcl.h: Removed TCL_PREFIX_IDENT and TCL_DEBUG_IDENT
* win/tclWinPipe.c: from tcl.h -- they are not part of Tcl's
public interface. Put them in win/tclWinPipe.c where they are used.
* generic/tclCmdMZ.c (Tcl_SubstObj): Corrected and added test for
* tests/subst.test (subst-2.4): Tcl_SubstObj's incorrect
halting of substitution at the first \x00 byte. [Bug 685106]
* generic/tclInterp.c (Tcl_InterpObjCmd): Corrected and added
* tests/interp.test (interp-2.13): test for option
parsing beyond objc for [interp create --]. Thanks to Marco Maggi.
[Bug 702383]
2003-03-11 Kevin Kenny <kennykb@users.sourceforge.net>
* win/makefile.vc: Added two missing uses of $(DBGX) so that
tclpip8x.dll loads without panicking on Win9x.
2003-03-08 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n: Added missing "-body" to example. Thanks to
Helmut Giese. [Bug 700011]
2003-03-06 Don Porter <dgp@users.sourceforge.net>
* generic/TclUtf.c (Tcl_UniCharNcasecmp): Corrected failure to
* tests/utf.test (utf-25.*): properly compare Unicode strings of
different case in a case insensitive manner. [Bug 699042]
2003-03-03 Jeff Hobbs <jeffh@ActiveState.com>
*** 8.4.2 TAGGED FOR RELEASE ***
2003-03-03 Daniel Steffen <das@users.sourceforge.net>
Mac OS Classic specific fixes:
|
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | * mac/tclMacPort.h: define S_ISLNK macro to fix stat'ing of links. * mac/tclMacUtil.c (FSpLocationFromPathAlias): fix to enable stat'ing of broken links. 2003-03-03 Kevin Kenny <kennykb@users.sourceforge.net> * win/Makefile.vc: corrected bug introduced by 'g' for debug builds. | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | < | | < | | | | | | | | | | | | | > | | < | | | | | < | | | | | | | | | | | | | < | | | < | < | | < | | | | | | | | | | | | | | | | | | < | < | | < | | | | < | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | < | | < | | < | | | | | | < | | | | | | | | | | < | | | < | | < | | | < | < | | | < | | < | | | | | | | | | | | | | | | | | | | < | | | | < | | < | | | < | | < | < | | < | | | | < | | < | | | | | | < | | | | | | < | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | < | | < | | < | < | | | < | < | < | | | < | | < | | < | | | | < | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | < | | | | | | | | < | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | < | | < | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | < | | | < > | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 |
* mac/tclMacPort.h: define S_ISLNK macro to fix stat'ing of links.
* mac/tclMacUtil.c (FSpLocationFromPathAlias): fix to enable
stat'ing of broken links.
2003-03-03 Kevin Kenny <kennykb@users.sourceforge.net>
* win/Makefile.vc: corrected bug introduced by 'g' for debug builds.
2003-03-03 Don Porter <dgp@users.sourceforge.net>
* library/dde/pkgIndex.tcl: dde bumped to version 1.2.1 for
* win/tclWinDde.c: bundled release with Tcl 8.4.2
* library/reg/pkgIndex.tcl: registry bumped to version 1.1.1 for
* win/tclWinReg.c: bundled release with Tcl 8.4.2
* library/opt/pkgIndex.tcl: updated package index to version 0.4.4
2003-02-28 Jeff Hobbs <jeffh@ActiveState.com>
* win/configure:
* win/configure.in: check for 'g' for debug build type, not 'd'.
* win/rules.vc (DBGX): correct to use 'g' for nmake win makefile
to match the cygwin makefile for debug builds. [Bug 635107]
2003-02-28 Vince Darley <vincentdarley@users.sourceforge.net>
* doc/file.n: subcommand is 'file volumes' not 'file volume'
2003-02-27 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIOUtil.c (MakeFsPathFromRelative): removed dead code
check of typePtr (darley).
* tests/winTime.test: added note about PCI hardware dependency
issues with high performance clock.
2003-02-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/lsearch.test (lsearch-10.7):
* generic/tclCmdIL.c (Tcl_LsearchObjCmd): Stopped -start option from
causing an option when used with an empty list. [Bug 694232]
2003-02-26 Chengye Mao <chengye.geo@yahoo.com>
* win/tclWinInit.c: fixed a bug in TclpSetVariables by initializing
dwUserNameLen with the sizeof(szUserName) before calling GetUserName.
Don't know if this bug has been recorded: it caused crash in starting
Tcl or wish in Windows.
2003-02-26 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclCmdMZ.c (TraceCommandProc): Fix mem leak when
deleting a command that had trace on it. [Bug 693564] (sofer)
2003-02-25 Don Porter <dgp@users.sourceforge.net>
* doc/pkgMkIndex.n: Modified [pkg_mkIndex] to use -nocase matching
* library/package.tcl: of -load patterns, to better accomodate
common user errors due to confusion between [package names] names
and [info loaded] names.
2003-02-25 Andreas Kupries <andreask@activestate.com>
* tests/pid.test: See below [Bug 678412].
* tests/io.test: Made more robust against spaces in paths [Bug 678400]
2003-02-25 Miguel Sofer <msofer@users.sf.net>
* tests/execute.test: cleaning up testobj's at the end, to avoid leak
warning by valgrind.
2003-02-22 Zoran Vasiljevic <zoran@archiwrae.com>
* generic/tclEvent.c (Tcl_FinalizeThread): Fix [Bug 571002]
2003-02-21 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/binary.test (binary-44.[34]):
* generic/tclBinary.c (ScanNumber): Fixed problem with unwanted
sign-bit propagation when scanning wide ints. [Bug 690774]
2003-02-21 Daniel Steffen <das@users.sourceforge.net>
* mac/tclMacChan.c (TclpCutFileChannel, TclpSpliceFileChannel):
Implemented missing cut and splice procs for file channels.
2003-02-21 Don Porter <dgp@users.sourceforge.net>
* library/package.tcl (tclPkgUnknown): Minor performance tweaks to
reduce the number of [file] invocations. Meant to improve startup
times, at least a little bit. [Patch 687906]
2003-02-20 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4:
* unix/tclUnixPipe.c: (macosx) use vfork() instead of fork() to create
new processes, as recommended by Apple (vfork can be up to 100 times
faster thank fork on macosx).
* unix/configure: regen.
2003-02-20 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclEncoding.c (LoadTableEncoding):
* library/encoding/cp932.enc: Correct jis round-trip encoding
* library/encoding/euc-jp.enc: by adding 'R' type to .enc files.
* library/encoding/iso2022-jp.enc: [Patch 689341] (koboyasi, taguchi)
* library/encoding/jis0208.enc:
* library/encoding/shiftjis.enc:
* tests/encoding.test:
* unix/tclUnixChan.c (Tcl_MakeTcpClientChannel): add
MakeTcpClientChannelMode that takes actual mode flags to avoid
hang on OS X (may be OS X bug, but patch works x-plat).
[Bug 689835] (steffen)
2003-02-20 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/regsub.n: Typo fix [Bug 688943]
2003-02-19 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixThrd.c (TclpReaddir):
* unix/tclUnixPort.h: update to Bug 689100 patch to ensure that
there is a defined value of MAXNAMLEN (aka NAME_MAX in POSIX) and
that we have some buffer allocated.
2003-02-19 Daniel Steffen <das@users.sourceforge.net>
* generic/tclStringObj.c: restored Tcl_SetObjLength() side-effect of
always invalidating unicode rep (if the obj has a string rep). Added
hasUnicode flag to String struct, allows decoupling of validity of
unicode rep from buffer size allocated to it (improves memory
allocation efficiency). [Bugs 686782, 671138, 635200]
* macosx/Tcl.pbproj/project.pbxproj:
* macosx/Makefile: reworked embedded build to no longer require
relinking but to use install_name_tool instead to change the
install_names for embedded frameworks. [Bug 644510]
* macosx/Tcl.pbproj/project.pbxproj: preserve mod dates when running
'make install' to build framework (avoids bogus rebuilds of dependent
frameworks because tcl headers appear changed).
* tests/ioCmd.test (iocmd-1.8): fix failure when system encoding is
utf-8: use iso8859-1 encoding explicitly.
2003-02-18 Miguel Sofer <msofer@users.sf.net>
* generic/tclCompile.c (TclCompileExprWords): remove unused variable
"range" [Bug 664743]
* generic/tclExecute.c (ExprSrandFunc): remove unused variable
"result" [Bug 664743]
* generic/tclStringObj.c (UpdateStringOfString): remove unused
variable "length" [Bug 664751]
* tests/execute.test (execute-7.30): fix for [Bug 664775]
2003-02-18 Andreas Kupries <andreask@activestate.com>
* unix/tcl.m4: [Bug 651811] Added definition of _XOPEN_SOURCE and
linkage of 'xnet' library to HP 11 branch. This kills a lot of
socket-related failures in the testsuite when Tcl was compiled in 64
bit mode (both PA-RISC 2.0W, and IA 64).
* unix/configure: Regenerated.
2003-02-18 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIO.c (HaveVersion): correctly decl static
* unix/tclUnixThrd.c (TclpReaddir): reduce size of name string in
tsd to NAME_MAX instead of PATH_MAX. [Bug 689100] (waters)
2003-02-18 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4 (SC_ENABLE_THREADS): Make sure -lpthread gets passed on
the link line when checking for the pthread_attr_setstacksize symbol.
2003-02-18 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclTest.c: cleanup of new 'simplefs' test code, and better
documentation.
2003-02-17 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c (TclRenameCommand): fixing error in previous
commit.
2003-02-17 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclExecute.c (TclExecuteByteCode INST_STR_MATCH):
* generic/tclCmdMZ.c (Tcl_StringObjCmd STR_MATCH):
* generic/tclUtf.c (TclUniCharMatch):
* generic/tclInt.decls: add private TclUniCharMatch function that
* generic/tclIntDecls.h: does string match on counted unicode
* generic/tclStubInit.c: strings. Tcl_UniCharCaseMatch has the
* tests/string.test: failing that it can't handle strings or
* tests/stringComp.test: patterns with embedded NULLs. Added
tests that actually try strings/pats with NULLs. TclUniCharMatch
should be TIPed and made public in the next minor version rev.
2003-02-17 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c (TclRenameCommand): 'oldFullName' object was not
being freed on all function exits, causing a memory leak. [Bug 684756]
2003-02-17 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tclIO.c (Tcl_GetsObj): Minor change so that eol is only
assigned at the top of the TCL_TRANSLATE_AUTO case block. The other
cases assign eol so this does not change any functionality.
2003-02-17 Kevin Kenny <kennykb@users.sourceforge.net>
* tests/notify.test: Removed Windows line terminators. [Bug 687913].
2003-02-15 Miguel Sofer <msofer@users.sf.net>
* generic/tclBasic.c (Tcl_EvalEx):
* generic/tclCompExpr.c (CompileSubExpr):
* generic/tclCompile.c (TclCompileScript):
* generic/tclParse.c (Tcl_ParseCommand, ParseTokens):
* generic/tclParseExpr.c (ParsePrimaryExpr):
* tests/basic.test (47.1):
* tests/main.test (3.4):
* tests/misc.test (1.2):
* tests/parse.test (6.18):
* tests/parseExpr.test (15.35):
* tests/subst.test (8.6): Don Porter's fix for bad parsing of
nested scripts [Bug 681841].
2003-02-15 Kevin Kenny <kennykb@users.sourceforge.net>
* tests/notify.test (new-file):
* generic/tclTest.c (TclTest_Init, EventtestObjCmd, EventtestProc,
(EventTestDeleteProc):
* generic/tclNotify.c (Tcl_DeleteEvents): Fixed Tcl_DeleteEvents
not to get a pointer smash when deleting the last event in the
queue. Added test code in 'tcltest' and a new file of test cases
'notify.test' to exercise this functionality; several of the new
test cases fail for the original code and pass for the corrected
code. [Bug 673714]
* unix/tclUnixTest.c (TestfilehandlerCmd): Corrected a couple
of typos in error messages. [Bug 596027]
2003-02-14 Jeff Hobbs <jeffh@ActiveState.com>
* README: Bumped to version 8.4.2.
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure:
* unix/configure.in:
* unix/tcl.m4:
* unix/tcl.spec:
* win/README.binary:
* win/configure:
* win/configure.in:
* macosx/Tcl.pbproj/project.pbxproj:
* generic/tclStringObj.c (Tcl_GetCharLength): perf tweak
* unix/tcl.m4: correct HP-UX ia64 --enable-64bit build flags
2003-02-14 Kevin Kenny <kennykb@users.sourceforge.net>
* win/tclWinTime.c: Added code to test and compensate for forward
leaps of the performance counter. See the MSDN Knowledge Base article
Q274323 for the hardware problem that makes this necessary on certain
machines.
* tests/winTime.test: Revised winTime-2.1 - it had a tolerance of
thousands of seconds, rather than milliseconds. (What's six orders of
magnitude among friends?
Both the above changes are triggered by a problem reported at
http://aspn.activestate.com/ASPN/Mail/Message/ActiveTcl/1536811
although the developers find it difficult to believe that it accounts
for the observed behavior and suspect a fault in the RTC chip.
2003-02-13 Kevin Kenny <kennykb@users.sourceforge.net>
* win/tclWinInit.c: Added conversion from the system encoding to
tcl_platform(user), so that it works with non-ASCII7 user names. [Bug
685926]
* doc/tclsh.1: Added language to describe the handling of the
end-of-file character \u001a embedded in a script file. [Bug 685485]
2003-02-11 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/fileName.test:
* unix/tclUnixFile.c: fix for [Bug 685445] when using 'glob -l' on
broken symbolic links. Added two new tests for this bug.
2003-02-11 Kevin Kenny <kennykb@users.sourceforge.net>
* tests/http.test: Corrected a problem where http-4.14 would fail when
run in an environment with a proxy server. Replaced references to
scriptics.com by tcl.tk.
2003-02-11 Jeff Hobbs <jeffh@ActiveState.com>
* tests/lsearch.test:
* generic/tclCmdIL.c (Tcl_LsearchObjCmd): protect against the case
that lsearch -regepx list and pattern objects are equal.
* tests/stringObj.test:
* generic/tclStringObj.c (Tcl_GetCharLength): correct ascii char
opt of 2002-11-11 to not stop early on \x00. [Bug 684699]
* tests.parse.test: remove excess EOF whitespace
* generic/tclParse.c (CommandComplete): more paranoid check to
break on (p >= end) instead of just (p == end).
2003-02-11 Miguel Sofer <msofer@users.sf.net>
* generic/tclParse.c (CommandComplete):
* tests/parse.test: fix for [Bug 684744], by Don Porter.
2003-02-11 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIOUtil.c (Tcl_FSJoinPath, Tcl_FSGetNormalizedPath):
(UpdateStringOfFsPath): revert the cwdLen == 0 check and instead
follow a different code path in Tcl_FSJoinPath.
(Tcl_FSConvertToPathType, Tcl_FSGetNormalizedPath):
(Tcl_FSGetFileSystemForPath): Update string rep of path objects
before freeing the internal object. (darley)
* tests/fileSystem.test: added test 8.3
* generic/tclIOUtil.c (Tcl_FSGetNormalizedPath):
(UpdateStringOfFsPath): handle the cwdLen == 0 case
* unix/tclUnixFile.c (TclpMatchInDirectory): simplify the hidden
file match check.
2003-02-10 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure:
* win/configure.in: Generate error when attempting to build under
Cygwin. The Cygwin port of Tcl/Tk does not build and people are filing
bug reports under the mistaken impression that someone is actually
maintaining the Cygwin port. A post to comp.lang.tcl asking someone to
volunteer as an area maintainer has generated no results. Closing
[Bugs 680840, 630199, 634772] and marking as "Won't fix".
2003-02-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/append.n: Return value was not documented. [Bug 683188]
2003-02-10 Vince Darley <vincentdarley@users.sourceforge.net>
* doc/FileSystem.3:
* generic/tclIOUtil.c:
* generic/tclInt.h:
* tests/fileSystem.test:
* unix/tclUnixFCmd.c:
* unix/tclUnixFile.c:
* win/tclWinFile.c: further filesystem optimization, applying
[Patch 682500]. In particular, these code examples are faster now:
foreach f $flist { if {[file exists $f]} {file stat $f arr;...}}
foreach f [glob -dir $dir *] { # action and/or recursion on $f }
cd $dir
foreach f [glob *] { # action and/or recursion on $f }
cd ..
* generic/tclTest.c: Fix for [Bug 683181] where test suite left files
in 'tmp'.
2003-02-08 Jeff Hobbs <jeffh@ActiveState.com>
* library/safe.tcl: code cleanup of eval and string comp use.
2003-02-07 Vince Darley <vincentdarley@users.sourceforge.net>
* win/tclWinFCmd.c: cleanup long lines
* win/tclWinFile.c: sped up pure 'glob' by a factor of 2.5 ('foreach f
[glob *] { file exists $f }' is still slow)
* tests/fileSystem.text:
* tests/fileName.test: added new tests to ensure correct behaviour in
optimized filesystem code.
2003-02-07 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclTest.c:
* tests/fileSystem.text: fixed test 7.2 to avoid a possible crash, and
not change the pwd.
* tests/http.text: added comment to test 4.15, that it may fail if you
use a proxy server.
2003-02-06 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tclCompCmds.c (TclCompileIncrCmd):
* tests/incr.test: Don't include the text "(increment expression)" in
the errorInfo generated by the compiled version of the incr command
since it does not match the message generated by the non-compiled
version of incr. It is also not possible to match this error output
under Jacl, which does not support a compiler.
2003-02-06 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tclExecute.c (TclExecuteByteCode): When an error is
encountered reading the increment value during a compiled call to
incr, add a "(reading increment)" error string to the errorInfo
variable. This makes the errorInfo variable set by the compiled incr
command match the value set by the non-compiled version.
* tests/incr-old.test: Change errorInfo result for the compiled incr
command case to match the modified implementation.
* tests/incr.test: Add tests to make sure the compiled and
non-compiled errorInfo messages are the same.
2003-02-06 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Filename arguments to [outputChannel]
and [errorChannel] (also -outfile and -errfile) were [open]ed but
never [closed]. Also, [cleanupTests] could remove output or error
files. [Bug 676978].
* library/tcltest/pkgIndex.tcl: Bumped to version 2.2.2.
2003-02-05 Mo DeJong <mdejong@users.sourceforge.net>
* tests/interp.test:
* tests/set-old.test: Run test cases that depend on hash order through
lsort so that the tests also pass under Jacl. Does not change test
results under Tcl.
2003-02-04 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c:
* generic/tclEvent.c:
* generic/tclInt.h:
* mac/tclMacFCmd.c:
* unix/tclUnixFCmd.c:
* win/tclWin32Dll.c:
* win/tclWinFCmd.c:
* win/tclWinInit.c:
* win/tclWinInt.h:
* tests/fileSystem.test: fix to finalization/unloading/encoding issues
to make filesystem much less dependent on encodings for its cleanup,
and therefore allow it to be finalized later in the exit process. This
fixes fileSystem.test-7.1. Also fixed one more bug in setting of
modification dates of files which have undergone cross-platform
copies. [Patch 676271]
* tests/basic.test:
* tests/exec.test:
* tests/fileName.test:
* tests/io.test: fixed some test failures when tests are run from a
directory containing spaces.
* tests/fileSystem.test:
* generic/tclTest.c: added regression test for the modification
date setting of cross-platform file copies.
2003-02-03 Kevin Kenny <kennykb@users.sourceforge.net>
* generic/tclBasic.c: Changed [trace add command] so that 'rename'
callbacks get fully qualified names of the command. [Bug 651271].
***POTENTIAL INCOMPATIBILITY***
* tests/trace.test: Modified the test cases for [trace add command] to
expect fully qualified names on the 'rename' callbacks. Added a case
for renaming a proc within a namespace.
* doc/trace.n: Added language about use of fully qualified names in
trace callbacks.
2003-02-01 Kevin Kenny <kennykb@users.sourceforge.net>
* generic/tclCompCmds.c: Removed an unused variable that caused
compiler warnings on SGI. [Bug 664379]
* generic/tclLoad.c: Changed the code so that if Tcl_StaticPackage is
called to report the same package as being loaded in two interps, it
shows up in [info loaded {}] in both of them (previously, it didn't
appear in the static package list in the second.
* tests/load.test Added regression test for the above bug. [Bug
670042]
* generic/tclClock.c: Fixed a bug that incorrectly allowed [clock
clicks {}] and [clock clicks -] to be accepted as if they were [clock
clicks -milliseconds].
* tests/clock.test: Added regression tests for the above bug. [Bug
675356]
* tests/unixNotfy.test: Added cleanup of working files [Bug 675609]
* doc/Tcl.n: Added headings to the eleven paragraphs, to improve
formatting in the tools that attempt to extract tables of contents
from the manual pages. [Bug 627455]
* generic/tclClock.c: Expanded mutex protection around the setting of
env(TZ) and the thread-unsafe call to tzset(). [Bug 656660]
2003-01-31 Don Porter <dgp@users.sourceforge.net>
* tests/tcltest.test: Cleaned up management of file/directory
creation/deletion to improve "-debug 1" output. [Bug 675614] The
utility [slave] command failed to properly [list]-quote a constructed
[open] command, causing failure when the pathname contained
whitespace. [Bug 678415]
* tests/main.test: Stopped main.test from deleting existing file.
Test suite should not delete files that already exist. [Bug 675660]
2003-01-28 Don Porter <dgp@users.sourceforge.net>
* tests/main.test: Constrain tests that do not work on Windows. [Bug
674387]
2003-01-28 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c: fix to setting modification date in
TclCrossFilesystemCopy. Also added 'panic' in
Tcl_FSGetFileSystemForPath under illegal calling circumstances which
lead to hard-to-track-down bugs.
* generic/tclTest.c: added test suite code to allow exercising a
vfs-crash-on-exit bug in Tcl's finalization caused by the encodings
being cleaned up before unloading occurs.
* tests/fileSystem.test: added new 'knownBug' test 7.1 to demonstrate
the crash on exit.
2003-01-28 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tcl.h: Add TCL_PREFIX_IDENT and TCL_DEBUG_IDENT, used only
by TclpCreateProcess.
* unix/Makefile.in: Define TCL_DBGX.
* win/Makefile.in: Define TCL_DBGX.
* win/tclWinPipe.c (TclpCreateProcess): Check that the Tcl pipe dll
actually exists in the Tcl bin directory and panic if it is not
found. Incorporate TCL_DBGX into the Tcl pipe dll name. This fixes a
really mysterious error that would show up when exec'ing a 16 bit
application under Win95 or Win98 when Tcl was compiled with symbols.
The error seemed to indicate that the executable could not be found,
but it was actually the Tcl pipe dll that could not be found.
2003-01-26 Mo DeJong <mdejong@users.sourceforge.net>
* win/README: Update msys+mingw URL to release 6. This version bundles
gcc 3.
2003-01-26 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure: Regen.
* win/configure.in: Add test that checks to see if the compiler can
cast to a union type.
* win/tclWinTime.c: Squelch compiler warning about union initializer
by casting to union type when compiling with gcc.
2003-01-25 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tclIO.c (Tcl_CutChannel, Tcl_SpliceChannel): Invoke
TclpCutFileChannel and TclpSpliceFileChannel.
* generic/tclInt.h: Declare TclpCutFileChannel and
TclpSpliceFileChannel.
* unix/tclUnixChan.c (FileCloseProc, TclpOpenFileChannel,
(Tcl_MakeFileChannel, TclpCutFileChannel,
(TclpSpliceFileChannel): Implement thread load data cut and splice for
file channels. This avoids an invalid memory ref when compiled with
-DDEPRECATED.
* win/tclWinChan.c (FileCloseProc, TclpCutFileChannel,
(TclpSpliceFileChannel): Implement thread load data cut and splice for
file channels. This avoids an invalid memory ref that was showing up
in the thread extension.
2003-01-25 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWin32Dll.c (TclpCheckStackSpace, squelch_warnings):
* win/tclWinChan.c (Tcl_MakeFileChannel, squelch_warnings):
* win/tclWinFCmd.c (DoRenameFile, DoCopyFile, squelch_warnings):
Re-implement inline ASM SEH handlers for gcc. The esp and ebp
registers are now saved on the stack instead of in global variables so
that the code is thread safe. Add additional checks when TCL_MEM_DEBUG
is defined to be sure the values were recovered from the stack
properly. Remove squelch_warnings functions and add a dummy call in
the handler methods to squelch compiler warnings.
2003-01-25 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure:
* win/configure.in: Define HAVE_ALLOCA_GCC_INLINE when we detect that
no alloca function is found in malloc.h and we are compiling with
GCC. Remove HAVE_NO_ALLOC_DECL define.
* win/tclWin32Dll.c (TclpCheckStackSpace): Don't define alloca as a
cdecl function. Doing this caused a tricky runtime bug because the
_alloca function expects the size argument to be passed in a register
and not on the stack. To fix this problem, we use inline ASM when
compiling with gcc to invoke _alloca with the size argument loaded
into a register.
2003-01-24 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinDde.c (Dde_Init): clarified use of tsdPtr.
(DdeServerProc): better refcount handling of returnPackagePtr.
* generic/tclEvent.c (Tcl_Finalize): revert finalize change on
2002-12-04 to correct the issue with extensions that have TSD needing
to finalize that before they are unloaded. This issue needs further
clarification.
* tests/unixFCmd.test: only do groups check on unix
2003-01-24 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclStringObj.c: proper fixes for Tcl_SetObjLength and
Tcl_AttemptSetObjectLength dealing with string objects with both
pure-unicode and normal internal representations. Previous fix didn't
handle all cases correctly.
* generic/tclIO.c: Add 'Tcl_GetString()' to ensure the object has a
valid 'objPtr->bytes' field before manipulating it directly.
This fixes [Bug 635200] and [Bug 671138], but may reduce performance
of Unicode string handling in some cases. A further patch will be
applied to address this, once the code is known to be correct.
2003-01-24 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure: Regen.
* win/configure.in: Add test to see if alloca is undefined in
malloc.h.
* win/tclWin32Dll.c (TclpCheckStackSpace): Rework the SEH exception
handler logic to avoid using the stack since alloca will modify the
stack. This was causing a nasty bug that would set the exception
handler to 0 because it tried to pop the previous exception handler
off the top of the stack.
2003-01-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/lset.n: Fixed fault in return values from lset in documentation
examples [Bug 658463] and tidied up a bit at the same time.
2003-01-21 Joe English <jenglish@users.sourceforge.net>
* doc/namespace.n (namespace inscope): Clarified documentation
[Patch 670110]
2003-01-21 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure: Regen.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Set SHLIB_SUFFIX so that
TCL_SHLIB_SUFFIX will be set to a useful value in the generated
tclConfig.sh. Set SHLIB_LD_LIBS to "" or '${LIBS}' based on the
--enable-shared flag. This matches the UNIX implementation.
2003-01-18 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclCkalloc.c: change %ud to %u as appropriate.
2003-01-17 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWinDde.c (DdeServerProc): Deallocate the Tcl_Obj returned by
ExecuteRemoteObject if it was not saved in a connection object.
2003-01-17 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tcl.h: Revert earlier change that defined TCL_WIDE_INT_TYPE
as long long and TCL_LL_MODIFIER as L when compiling with mingw. This
change ended up causing some test case failures when compiling with
mingw.
* generic/tclObj.c (UpdateStringOfWideInt): Describe the warning
generated by mingw and why it needs to be ignored so that someone is
not tempted to "fix" this problem again in the future.
2003-01-16 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclStringObj.c: Tcl_SetObjLength fix for when the object has
a unicode string rep. Fixes [Bug 635200]
* tests/stringObj.test: removed 'knownBug' constraint from test 14.1
now that this bug is fixed.
* generic/tclInt.h:
* generic/tclBasic.c:
* generic/tclCmdMZ.z:
* tests/trace.test: execution and command tracing bug fixes and
cleanup. In particular fixed [Bugs 655645, 615043, 571385]
- fixed some subtle cleanup problems with tracing. This required
replacing Tcl_Preserve/Tcl_Release with a more robust refCount
approach. Solves at least one known crash caused by memory
corruption.
- fixed some confusion in the code between new style traces (Tcl
8.4) and the very limited 'Tcl_CreateTrace' which existed before.
- made behaviour consistent with documentation (several tests even
contradicted the documentation before).
- fixed some minor error message details
- added a number of new tests
2003-01-16 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinSerial.c (SerialOutputProc): add casts for bytesWritten to
allow strict compilation (no warnings).
* tests/winDde.test:
* win/tclWinDde.c (Tcl_DdeObjCmd): Prevent crash when empty service
name is passed to 'dde eval' and goto errorNoResult in request and
poke error cases to free up any allocated data.
2003-01-16 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWin32Dll.c (squelch_warnings): Squelch compiler warnings from
SEH ASM code.
* win/tclWinChan.c (squelch_warnings): Squelch compiler warnings from
SEH ASM code.
* win/tclWinDde.c: Add casts to avoid compiler warnings. Pass pointer
to DWORD instead of int to avoid compiler warnings.
* win/tclWinFCmd.c (squelch_warnings): Add casts and fixup decls to
avoid compiler warnings. Squelch compiler warnings from SEH ASM code.
* win/tclWinFile.c: Add casts and fixup decls to avoid compiler
warnings. Remove unused variable.
* win/tclWinNotify.c: Declare as DWORD instead of int to avoid
compiler warning.
* win/tclWinReg.c: Add casts to avoid compiler warning. Fix assignment
in if expression bug.
* win/tclWinSerial.c: Add casts to avoid compiler warnings. Remove
unused variable.
* win/tclWinSock.c: Add casts and fixup decls to avoid compiler
warnings.
2003-01-14 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclClock.c (FormatClock): corrected typo that incorrectly
conditionally defined savedTZEnv and savedTimeZone.
2003-01-13 Mo DeJong <mdejong@users.sourceforge.net>
Fix mingw build problems and compiler warnings.
* generic/tcl.h: Add if defined(__MINGW32__) check to code that sets
the TCL_WIDE_INT_TYPE and TCL_LL_MODIFIER.
* generic/tclClock.c (FormatClock): Don't define savedTimeZone and
savedTZEnv if we are not going to use them.
* generic/tclEnv.c: Add cast to avoid warning.
* win/tclWinChan.c: Use DWORD instead of int to avoid compiler warning
* win/tclWinThrd.c: Only define allocLock, allocLockPtr, and dataKey
when TCL_THREADS is defined. This avoid a compiler warning about
unused variables.
2003-01-12 Mo DeJong <mdejong@users.sourceforge.net>
* win/README: Update msys + mingw URL, the new release includes the
released 1.0.8 version of msys which includes a number of bug fixes.
2003-01-12 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure: Regen.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Pull in addition of shell32.lib to
LIBS_GUI that was added to the Tk tcl.m4 but never made it back into
the Tcl version.
2003-01-12 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tcl.h: Skip Tcl's define of CHAR, SHORT, and LONG when
HAVE_WINNT_IGNORE_VOID is defined. This avoids a bunch of compiler
warnings when building with Cygwin or Mingw.
* win/configure: Regen.
* win/configure.in: Define HAVE_WINNT_IGNORE_VOID when we detect a
winnt.h that still defines CHAR, SHORT, and LONG when VOID has already
been defined.
* win/tcl.m4 (SC_LOAD_TCLCONFIG): Subst the TCL_DEFS loaded from
tclConfig.sh so that Tcl defines can make it into the Tk Makefile.
2003-01-12 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure: Regen.
* win/configure.in: Check for typedefs like LPFN_ACCEPT in winsock2.h
and define HAVE_NO_LPFN_DECLS if not found.
* win/tclWinSock.c: Define LPFN_* typedefs if HAVE_NO_LPFN_DECLS is
defined. This fixes the build under Mingw and Cygwin, it was broken by
the changes made on 2002-11-26.
2003-01-10 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c:
* win/tclWinInt.h:
* win/tclWinInit.c: fix to new WinTcl crash on exit with vfs,
introduced on 2002-12-06. Encodings must be cleaned up after the
filesystem.
* win/makefile.vc: fix to minor VC++ 5.2 syntax problem
2003-01-09 Don Porter <dgp@users.sourceforge.net>
* generic/tclCompCmds.c (TclCompilerReturnCmd): Corrected off-by-one
problem with recent commit. [Bug 633204]
2003-01-09 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFileName.c: remove unused variable 'macSpecialCase' [Bug
664749]
* generic/tclIOUtil.c:
* generic/tclInt.h:
* unix/tclUnixFile.c:
* mac/tclMacFile.c:
* win/tclWinFile.c:
* win/tclWinInt.h:
* win/tclWin32Dll.c:
* tests/cmdAH.test: fix to non-ascii chars in paths when setting mtime
and atime through 'file (a|m)time $path $time'. [Bug 634151]
2003-01-08 Don Porter <dgp@users.sourceforge.net>
* generic/tclExecute.c (TclExprFloatError): Use the IS_NAN macro for
greater clarity of code.
2003-01-07 Don Porter <dgp@users.sourceforge.net>
* generic/tclCompCmds.c (TclCompileReturnCmd):
* tests/compile.test: Corrects failure of bytecompiled [catch
{return}] to have result TCL_RETURN (not TCL_OK) [Bug 633204]. This
patch is a workaround for 8.4.X. A new opcode INST_RETURN is a better
long term solution for 8.5 and later.
2003-01-04 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc:
* win/rules.vc: Fixed INSTALLDIR macro problem that blanked itself by
accident causing the install target to put the tree at the root of the
drive built on. Whoops..
Renamed the 'linkexten' option to be 'staticpkg'. Added 'thrdalloc' to
allow the switching _on_ of the thread allocator. Under testing, I
found it not to be benificial under windows for the purpose of the
application I was using it for. It was more important for this app
that resources for tcl threads be returned to the system rather than
saved/moved to the global recycler. Be extra clean or extra fast for
the default threaded build? Let's move to clean and allow it to be
switched on for users who find it benificial for their use of threads.
2002-12-18 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc: some uses of xcopy swapped to the @$(CPY) macro.
Reported by Joe Mistachkin <joe@mistachkin.com>.
2002-12-17 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclNotify.c (TclFinalizeNotifier, Tcl_SetServiceMode):
(Tcl_ThreadAlert): Check that the stub functions are non-NULL before
calling them. They could be set to NULL by Tcl_SetNotifier.
2002-12-16 David Gravereaux <davygrvy@pobox.com>
* generic/tclPipe.c (TclCleanupChildren):
* tests/winPipe.test:
* win/tclWinPipe.c (Tcl_WaitPid):
* win/tclWinTest.c: Gave Tcl_WaitPid the ability to return a Win32
exception code translated into a posix style SIG*. This allows [close]
to report "CHILDKILLED" without the meaning getting lost in a
truncated exit code. In TclCleanupChildren(), TclpGetPid() had to get
moved to before Tcl_WaitPid() as the the handle is removed from the
list taking away the ability to get the process id after the wait is
done. This shouldn't effect the unix implimentaion unless waitpid is
called with a pid of zero, meaning "any". I don't think it is..
2002-12-13 Don Porter <dgp@users.sourceforge.net>
* unix/configure.in: Updated configure of CVS snapshots to reflect
* win/configure.in: the 8.4.1.1 patchlevel.
* unix/configure: autoconf
* win/configure autoconf
2002-12-11 Don Porter <dgp@users.sourceforge.net>
* generic/tclProc.c (ProcessProcResultCode): Fix failure to propagate
negative return codes up the call stack. [Bug 647307]
* tests/proc.test (proc-6.1): Test for Bug 647307
* generic/tclParseExpr.c (TclParseInteger): Return 1 for the
string "0x" (recognize leading "0" as an integer). [Bug 648441].
* tests/parseExpr.test (parseExpr-19.1): Test for Bug 648441.
2002-12-09 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinThrd.c (TclpMasterUnlock):
* generic/tclThread.c (TclFinalizeThreadData): TclpMasterUnlock must
exist and be called unconditional of TCL_THREADS. [Bug 651139]
2002-12-08 David Gravereaux <davygrvy@pobox.com>
* win/tclWinSock.c (SocketThreadExitHandler, InitSockets): Check that
the tsdPtr is valid before dereferencing as we call it from the exit
handler, too [Bug 650353]. Another WSAStartup() loaded version
comparison byte swap issue fixed. Although 0x0101 byte swapped is
still 0x0101, properly claiming which is major/minor is more correct.
2002-12-06 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclStubInit.c: regen
* generic/tclIntPlatDecls.h: regen
* generic/tclInt.decls: added TclWinResetInterface
* win/tclWin32Dll.c (TclWinResetInterfaces):
* win/tclWinInit.c (TclpSetInitialEncodings, WinEncodingsCleanup):
add exit handler that resets the encoding information to a state where
we can reuse Tcl. Following these changes, it is possible to reuse Tcl
(following Tcl_FindExecutable or Tcl_CreateInterp) following a
Tcl_Finalize.
* generic/tclIOUtil.c (TclFinalizeFilesystem): reset statics to their
original values on finalize to allow reuse of the library.
2002-12-04 David Gravereaux <davygrvy@pobox.com>
* win/tclWinPipe.c: reverted back to -r1.27 due to numerous test
failures that need to be resolved first. The idea was good, but the
details aren't.
2002-12-04 David Gravereaux <davygrvy@pobox.com>
* win/tclWinPipe.c (Tcl_WaitPid): When a process exits with an
exception, pass this notice on to the caller with a SIG* code rather
than truncating the exit code and missing the meaning. This allows
TclCleanupChildren() to report "CHILDKILLED".
This has a different behavior than unix in that closing the read pipe
to a process sends the SIGPIPE signal which is returned as a SIGPIPE
exit status. On windows, we send the process a CTRL_BREAK_EVENT and
get back a CONTROL_C_EXIT which is documented to mean a SIGINT which
seems wrong as a system, but is the correct exit status.
2002-12-04 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c: fix to redirected 'load' in virtual filesystem
for some Unix systems.
* generic/tclEvent.c: the filesystem must be cleaned up before the
encoding subsystem because it needs access to encodings. Fixes crash
on exit observed in embedded applications.
* generic/tclTestObj.c: patch omitted from previous change of
2002-11-13
2002-12-03 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclStubLib.c (Tcl_InitStubs): prevent the cached check of
tclStubsPtr to allow for repeated load/unload of the Tcl dll by
hosting apps. [Bug 615304]
2002-12-03 David Gravereaux <davygrvy@pobox.com>
* win/tclAppInit.c (sigHandler): Protect from trying to close a NULL
handle.
* win/tclWinPipe.c (PipeClose2Proc, TclpCreateProcess): Send a real
Win32 signal (CTRL_C_EVENT) when the read channel is brought down to
alert the child to close on its side. Start the process with
CREATE_NEW_PROCESS_GROUP to allow the ability to send these signals.
The following test case now brings down the child without the use of
an external [kill] command.
% set p [open "|[info name]" w+]
file8d5380
% pid $p
2876
% close $p <- now doesn't block in Tcl_WaitPid()
%
* win/tclWinPipe.c (PipeClose2Proc): Changed CTRL_C_EVENT to
CTRL_BREAK_EVENT as it can't be ignored by the child and proved to
work on [open "|netstat 1" w+] where CTRL_C_EVENT didn't.
2002-11-27 David Gravereaux <davygrvy@pobox.com>
* win/tclWinPort.h: Don't turn off winsock prototypes! TclX didn't
like it. Even though the core doesn't use the prototypes, do offer
them.
* win/tclWinSock.c: Removed shutdown() from the function table as it
wasn't referenced anywhere and cleaned-up some casting that that
wasn't needed.
* win/tclWinSock.c: WSAStartup() loaded version comparison error which
resulted in 2.0 looking less than 1.1.
* win/tclWinChan.c (Tcl_MakeFileChannel): return of DuplicateHandle()
incorrectly used [Bug 618852].
2002-11-26 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclEncoding.c (TclFinalizeEncodingSubsystem): properly
cleanup all encodings by using Tcl_FirstHashEntry in the while loop.
* unix/Makefile.in (valgrind): add simple valgrind target
* tests/exec.test: unset path var to allow singleproc testing
* generic/tclInterp.c (AliasCreate): preserve/release interps to
prevent possible FMR error in bad alias cases.
2002-11-26 David Gravereaux <davygrvy@pobox.com>
* win/tclWinPort.h:
* win/tclWinSock.c: This patch does two things:
1) Cleans-up the winsock typedefs by using the typedefs provided by
winsock2.h. This has no effect on how winsock is initialized; just
makes the source code easier to read. [Patch 561305, 561301]
2) Revamps how the socket message handler thread is brought up and
down to allow for cleaner exits without the use of TerminateThread().
TerminateThread is evil. No attempt has been made to resolve [Bug
593810] which may need a new channel driver version for adding a
registering function within the transfered thread to init the handler
thread. IOW, initialization of the TSD structure is getting bypassed
through the thread extension's [thread::transfer] command.
2002-11-26 David Gravereaux <davygrvy@pobox.com>
* win/tclWinConsole.c:
* win/tclWinPipe.c:
* win/tclWinSerial.c:
* win/tclWinSock.c:
* win/tclWinThrd.c:
* win/tclWinTime.c: General cleanup of all worker threads used by the
channel drivers. Eliminates the normal case where the worker thread is
terminated ('cept the winsock one). Instead, use kernel events to
signal a clean exit. Only when the worker thread is blocked on an I/O
call is the thread terminated. Essentially, this makes all other
channel worker threads behave like the PipeReaderThread() function for
it's cleaner exit behavior. This appears to fix [Bug 597924] but needs
3rd party confirmation to close the issue.
2002-11-26 Mo DeJong <mdejong@users.sourceforge.net>
* win/README: Update msys build env URL. This release #4 build both
tcl and tk without problems.
2002-11-22 Jeff Hobbs <jeffh@ActiveState.com>
* library/init.tcl: code cleanup to reduce use of
* library/opt/optparse.tcl: string compare
* tests/interp.test: interp-14.4
* generic/tclInterp.c (TclPreventAliasLoop): prevent seg fault when
creating an alias command over the interp name. [Bug 641195]
2002-11-18 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclUtil.c (SetEndOffsetFromAny): handle integer offset
after the "end-" prefix.
* generic/get.test:
* generic/string.test:
* generic/tclObj.c (SetIntFromAny, SetWideIntFromAny):
* generic/tclGet.c (TclGetLong, Tcl_GetInt): simplify sign handling
before calling strtoul(l). [Bug 634856]
2002-11-18 David Gravereaux <davygrvy@pobox.com>
* win/tclWinThrd.c (Tcl_CreateThread/TclpThreadExit): Fixed improper
compiler macros that missed the VC++ compiler. This resulted in VC++
builds using CreateThread()/ExitThread() in place of the proper
_beginthreadex()/_endthreadex(). This was a large error and am
surprised I missed seeing it earlier.
2002-11-13 Jeff Hobbs <jeffh@ActiveState.com>
* generic/regexpComp.test: added tests 22.*
* generic/tclCompCmds.c (TclCompileRegexpCmd): add left and right
anchoring (^ and $) recognition and check starting or ending .* to
extend the number of REs that can be compiled to string match or
string equal.
2002-11-13 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclCmdMZ.c:
* tests/trace.test: applied patch from Hemang Levana to fix [Bug
615043] in execution traces with 'return -code error'.
* generic/tclTestObj.c:
* tests/stringObj.test: added 'knownBug' test for [Bug 635200]
* generic/tclStringObj.c: corrected typos in comments
* generic/tclFileName.c:
* tests/fileName.test: applied patch for bug reported against tclvfs
concerning handling of Windows serial ports like 'com1', 'lpt3' by the
virtual filesystem code.
* doc/RegExp.3: clarification of the 'extendMatch' return values.
2002-11-11 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclUtil.c (Tcl_Backslash): use TclUtfToUniChar.
(Tcl_StringCaseMatch): use TclUtfToUniChar and add further
optimizations for the one-byte/char case.
* generic/tclUtf.c: make use of TclUtfToUniChar macro throughout the
functions, and add extra optimization to Tcl_NumUtfChars for
one-byte/char case.
* generic/tclVar.c (DisposeTraceResult, CallVarTraces): add proper
static declarations.
* generic/tclStringObj.c (Tcl_GetCharLength): optimize for the ascii
char case.
(Tcl_GetUniChar): remove unnecessary use of Tcl_UtfToUniChar.
(FillUnicodeRep): Use TclUtfToUniChar.
* generic/tclHash.c (HashStringKey): move string++ lower to save an
instruction.
* generic/tclExecute.c (TclExecuteByteCode): improve INST_STR_CMP to
use memcmp in the one-byte/char case, also use direct index for
INST_STR_INDEX in that case.
* generic/tclEncoding.c (UtfToUtfProc, UtfToUnicodeProc):
(TableFromUtfProc, EscapeFromUtfProc): Use TclUtfToUniChar.
(UnicodeToUtfProc, TableToUtfProc): add 1-byte char optimizations
for Tcl_UniCharToUtf call. These improve encoded channel conversion
speeds by up to 20%.
* tests/split.test: added 1-char string split tests
* generic/tclCmdMZ.c (Tcl_SplitObjCmd): Use TclUtfToUniChar. Also
added a special case for single-ascii-char splits.
(Tcl_StringObjCmd): Use TclUtfToUniChar. For STR_RANGE, support
getting ranges of ByteArrays (reverts change from 2000-05-26).
(TraceExecutionProc) add proper static declaration.
* generic/tclInt.h: add macro version of Tcl_UtfToUniChar
(TclUtfToUniChar) that does the one-byte utf-char check without
calling Tcl_UtfToUniChar, for use by the core. This brings notable
speedups for primarily ascii string handling.
* generic/tcl.h (TCL_PATCH_LEVEL): bump to 8.4.1.1 for patchlevel
only. This interim number will only be reflected by [info patchlevel]
2002-11-11 Kevin Kenny <kennykb@acm.org>
* doc/Tcl.n: Corrected indentation of the new language. Oops.
2002-11-10 Kevin Kenny <kennykb@acm.org>
* doc/Tcl.n: Added language to the Endekalogue to make it clear that
substitutions always take place from left to right. [Bug 635644]
2002-11-06 Mo DeJong <mdejong@users.sourceforge.net>
* changes: Note TclInExit TclInThreadExit changes.
* generic/tclEvent.c (TclInExit, TclInThreadExit):
Split out functionality of TclInExit to make it clear which one should
be called in each situation.
* generic/tclInt.decls: Declare TclInThreadExit.
* generic/tclIntDecls.h: Regen.
* generic/tclStubInit.c: Regen.
* mac/tclMacChan.c (StdIOClose):
* unix/tclUnixChan.c (FileCloseProc):
* win/tclWinChan.c (FileCloseProc):
* win/tclWinConsole.c (ConsoleCloseProc):
* win/tclWinPipe.c (TclpCloseFile):
* win/tclWinSerial.c (SerialCloseProc): Invoke the new TclInThreadExit
method instead of TclInExit.
2002-11-06 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Generate a fatal configure error if
no ar program can be found on the path. [Bug 582039]
* win/configure: Regen.
* win/configure.in: Check that AR, RANLIB, and RC are found on the
path when building with gcc.
2002-11-03 David Gravereaux <davygrvy@pobox.com>
* win/tclAppInit.c: Calls Registry_Init() and Dde_Init() when
STATIC_BUILD and TCL_USE_STATIC_PACKAGES macros are set.
* win/makefile.vc:
* win/rules.vc: linkexten option now sets the TCL_USE_STATIC_PACKAGES
macro which also adds the registry and dde object files to the link
of the shell. [Patch 479697] Also factored some additional macros
that will be helpful for extension authors. Version grepping of tcl.h
will need to be added to complete this.
* win/buildall.vc.bat: Added more descriptive commentary.
2002-11-01 David Gravereaux <davygrvy@pobox.com>
* win/tclWinReg.c: Changed the Tcl_PkgProvide() line to declare the
registry extension at version 1.1 from 1.0.
2002-10-31 Andreas Kupries <andreask@activestate.com>
* library/word.tcl: Changed $tcl_platform to $::tcl_platform to avoid
possible scope trouble.
2002-10-29 Vince Darley <vincentdarley@users.sourceforge.net>
* win/tclWinInt.h:
* win/tclWin32Dll.c: added comments about certain NULL function
pointers which will be filled in when Tcl_FindExecutable is called, so
that users don't report invalid bugs on this topic. (No code changes
at all).
2002-10-29 Daniel Steffen <das@users.sourceforge.net>
* unix/tclLoadDyld.c (TclpFindSymbol): pass all dyld error messages
upstream [Bug 627546].
2002-10-28 Andreas Kupries <andreask@activestate.com>
* library/dde/pkgIndex.tcl:
* library/reg/pkgIndex.tcl: Changed the hardwired debug suffix (d) to
the correct suffix (g).
2002-10-28 Don Porter <dgp@users.sourceforge.net>
* library/auto.tcl: Converted the Mac-specific [package unknown]
* library/init.tcl: behavior to use a chaining mechanism to extend
* library/package.tcl: the default [tclPkgUnknown]. [Bug 627660]
* library/tclIndex: [Patch 624509] (steffen)
2002-10-26 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc: xcopy on NT 4.0 doesn't support the /Y switch
(overwrite). Added logic to handle this. [Bug 618019]
2002-10-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclInt.h: Removed definitions of obsolete HistoryEvent and
HistoryRev structures (the history mechanism has been written in Tcl
for some time now).
2002-10-22 Jeff Hobbs <jeffh@ActiveState.com>
*** 8.4.1 TAGGED FOR RELEASE ***
* changes: updated for 8.4.1 release
* win/Makefile.in: removed @MEM_DEBUG_FLAGS@ subst.
* win/configure: regen
* win/configure.in: removed SC_ENABLE_MEMDEBUG call
* win/tcl.m4: replaced SC_ENABLE_MEMDEBUG with a more intelligent
SC_ENABLE_SYMBOLS that takes yes|no|mem|compile|all as options now.
2002-10-22 Daniel Steffen <das@users.sourceforge.net>
* library/auto.tcl (tcl_findLibrary):
* library/package.tcl (tclPkgUnknown): on macosx, search inside the
Resources/Scripts subdirectory of any potential package directory
* macosx/Tcl.pbproj/project.pbxproj: add standard Frameworks dirs to
TCL_PACKAGE_PATH make argument.
* unix/tclUnixInit.c (TclpSetVariables): on macosx, add embedded
framework dirs to tcl_pkgPath: @executable_path/../Frameworks and
@executable_path/../PrivateFrameworks (if they exist), as well as the
dirs in DYLD_FRAMEWORK_PATH (if set). [Patch 624509] use standard
MAXPATHLEN instead of literal 1024
2002-10-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/StringObj.3, doc/Object.3: Documented that Tcl_Obj's
standard string form is a modified UTF-8; apparently, this was not
mentioned anywhere in the main docs, and lead to [Bug 624919].
|
| ︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 | * library/reg/pkgIndex.tcl: * win/configure: * win/configure.in: * win/Makefile.in: * win/makefile.vc: * win/makefile.bc: Updated to reg1.1 | | | | | | | | | | | | | | | | | < | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | < | | | | | | | | | < | | | | | | | | < | | | | 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 |
* library/reg/pkgIndex.tcl:
* win/configure:
* win/configure.in:
* win/Makefile.in:
* win/makefile.vc:
* win/makefile.bc: Updated to reg1.1
* doc/registry.n: Added support for broadcasting changes to the
* tests/registry.test: registry Environment. Noted proper code in ths
* win/tclWinReg.c: docs. [Patch 625453]
* unix/Makefile.in (dist): add any mac/tcl*.sea.hqx files
2002-10-17 Don Porter <dgp@users.sourceforge.net>
* generic/tclVar.c: Fixed code that check for proper # of args to
* tests/var.test: [array names]. Added test. [Bug 624755]
2002-10-16 Jeff Hobbs <jeffh@ActiveState.com>
* win/configure: add workaround for cygwin windres
* win/tcl.m4 (SC_CONFIG_CFLAGS): problem. [Patch 624010] (howell)
2002-10-15 Jeff Hobbs <jeffh@ActiveState.com>
* README: added archives.tcl.tk note
* unix/configure:
* unix/tcl.m4: Correct AIX-5 ppc build flags. Correct HP 11 64-bit gcc
building. [Patch 601051] (martin)
2002-10-15 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclCmdMZ.c:
* tests/trace.test: applied patch from Hemang Levana to fix [Bug
615043] in execution traces with idle tasks firing.
2002-10-14 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclEnv.c (Tcl_PutEnv): correct possible mem leak.
[Patch 623269] (brouwers)
2002-10-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tcl.h: Need a different strategy through the maze of
#defines to let people building with Cygwin build correctly. Also
made some comments less misleading...
2002-10-10 Jeff Hobbs <jeffh@ActiveState.com>
* README: fixed minor nits [Bug 607776] (virden)
* win/configure:
* win/tcl.m4: enable USE_THREAD_ALLOC (new threaded allocator) by
default in cygwin configure on Windows.
2002-10-10 Don Porter <dgp@users.sourceforge.net>
* doc/Tcl.n: Clarified that namespace separators are legal in
the variable names during $-subtitution. [Bug 615139]
* doc/regexp.n: Typo correction. Thanks Ronnie Brunner. [Bug 606826]
2002-10-10 Vince Darley <vincentdarley@users.sourceforge.net>
* unix/tclLoadAout.c
* unix/tclLoadDl.c
* unix/tclLoadDld.c
* unix/tclLoadDyld.c
* unix/tclLoadNext.c
* unix/tclLoadOSF.c
* unix/tclLoadShl.c
* win/tclWinLoad.c: allow either full paths or simply dll names to be
specified when loading files (the latter will be looked up by the OS
on your PATH/LD_LIBRARY_PATH as appropriate). Fixes [Bug 611108]
2002-10-09 Jeff Hobbs <jeffh@ActiveState.com>
* unix/README: doc'ed --enable-symbols options.
* unix/Makefile.in: removed @MEM_DEBUG_FLAGS@ subst.
* unix/configure: regen
* unix/configure.in: removed SC_ENABLE_MEMDEBUG call
* unix/tcl.m4: replaced SC_ENABLE_MEMDEBUG with a more intelligent
SC_ENABLE_SYMBOLS that takes yes|no|mem|compile|all as options now.
2002-10-09 Kevin B. Kenny <kennykb@acm.org>
* win/tclWinTime.c: Added code to set an exit handler that terminates
the thread that calibrates the performance counter, so that the thread
won't outlive unloading the Tcl DLL. [Bug 620735].
2002-10-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/binary.n: More clarification of [binary scan]'s behaviour.
2002-10-09 Daniel Steffen <das@users.sourceforge.net>
* generic/tclIntDecls.h: fixed botched regen.
2002-10-09 Daniel Steffen <das@users.sourceforge.net>
* generic/tclInt.decls: made TclSetPreInitScript() declaration
generic as it is used on mac & aqua as well.
* generic/tclIntDecls.h:
* generic/tclStubInit.c: regen.
* generic/tclCompile.h: added prototype for TclCompileVariableCmd.
* mac/tclMacPort.h: removed incorrect <fcntl.h> definitions and
obsolete <stat.h> definitions.
* mac/tclMacChan.c: removed obsolete GetOpenMode() and replaced
associated constants with the <fcntl.h> analogues (they existing defs
were inconsistent with <fcntl.h> which was causing havoc when
Tcl_GetOpenMode was used instead of private GetOpenMode).
* mac/tclMacFCmd.c: removed GenerateUniqueName(), use equivalent (and
identically named) routine from MoreFiles instead.
* mac/tclMacLoad.c: CONSTification, fixes to Vince's last changes.
* mac/tclMacFile.c:
* mac/tclMacTest.c:
* mac/tclMacUnix.c: CONSTification.
* mac/tclMacOSA.c: CONSTification, sprintf fixes, UH 3.4.x changes;
fix for missing autoname token from TclOSACompileCmd. (bdesgraupes)
* mac/AppleScript.html(AppleScript delete): doc fix. (bdesgraupes)
* mac/tcltkMacBuildSupport.sea.hqx: updated MoreFiles to 1.5.3,
updated build instructions for 8.4.
* mac/tclMacProjects.sea.hqx: rebuilt archive.
2002-10-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/Alloc.3: Added a note to mention that attempting to allocate a
zero-length block can return NULL. [Tk Bug 619544]
2002-10-04 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/binary.n: Doc improvements [Patch 616480]
* tests/fCmd.test, tests/winFCmd.test:
* tools/eolFix.tcl, tools/genStubs.tcl: [file exist] -> [file exists]
Thanks to David Welton.
2002-10-03 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n: fixed typo [Bug 618018]. Thanks to "JJM".
2002-10-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tools/man2help2.tcl:
* tests/http.test, tests/httpd, tests/httpold.test:
* tests/env.test, tests/binary.test, tests/autoMkindex.test:
* library/init.tcl, library/http/http.tcl: [info exist] should really
be [info exists]. [Bug 602566]
* doc/lsearch.n: Better specification of what happens when -sorted is
mixed with other options. [Bug 617816]
2002-10-01 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclProc.c (TclCreateProc): mask out VAR_UNDEFINED for
precompiled locals to support 8.3 precompiled code.
(Tcl_ProcObjCmd): correct 2002-09-26 fix to look for tclProcBodyType.
2002-10-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/socket.n: Mentioned that ports may be specified as serivce names
as well as integers. [Bug 616843]
2002-09-30 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclCompCmds.c (TclCompileRegexpCmd): correct the checking
for bad re's that didn't terminate the re string. Resultant compiles
were correct, but much slower than necessary.
2002-09-29 David Gravereaux <davygrvy@pobox.com>
* win/tclAppInit.c: Added proper exiting conditions using Win32
console signals. This handles the existing lack of a Ctrl+C exit to
call exit handlers when built for thread support. Also, properly
handles exits from other conditions such as CTRL_CLOSE_EVENT,
CTRL_LOGOFF_EVENT, and CTRL_SHUTDOWN_EVENT signals. In all cases, exit
handlers will be called. [Bug 219355]
* win/makefile.vc: Added missing tclThreadAlloc.c to the build rules
and defines USE_THREAD_ALLOC when TCL_THREADS is defined to get the
new behavior by default.
2002-09-27 Don Porter <dgp@users.sourceforge.net>
* README: Bumped to version 8.4.1 to avoid confusion
* generic/tcl.h: of CVS snapshots with the actual 8.4.0
* tools/tcl.wse.in: release.
* unix/configure.in:
* unix/tcl.spec:
* win/configure.in:
* unix/configure: autoconf
* win/configure:
2002-09-26 Jeff Hobbs <jeffh@ActiveState.com>
* unix/configure: regen.
* unix/tcl.m4: improve AIX-4/5 64bit compilation support.
* generic/tclProc.c (Tcl_ProcObjCmd): correct overeager optimization
of noop proc to handle the precompiled case. (sofer)
* unix/ldAix (nmopts): add -X32_64 to make it work for 32 or 64bit
mode compilation.
* library/encoding/koi8-u.enc: removed extraneous spaces that confused
encoding reader. [Bug 615115]
* unix/Makefile.in: generate source dists with -src designator and do
not generate .Z anymore (just .gz and .zip).
2002-09-18 Mumit Khan <khan@nanotech.wisc.edu>
Added basic Cygwin support.
* win/tcl.m4 (SC_PATH_TCLCONFIG): Support one-tree build.
(SC_PATH_TKCONFIG): Likewise.
(SC_PROG_TCLSH): Likewise.
(SC_CONFIG_CFLAGS): Assume real Cygwin port and remove -mno-cygwin
flags. Add -mwin32 to extra_cflags and extra_ldflags. Remove ``-e
_WinMain@16'' from LDFLAGS_WINDOW.
* win/configure.in: Allow Cygwin build.
(SEH test): Define to be 1 instead of empty value.
(EXCEPTION_DISPOSITION): Add test.
* win/configure: Regenerate.
* generic/tcl.h: Don't explicitly define __WIN32__ for Cygwin, let the
user decide whether to use Windows or POSIX personality.
(TCL_WIDE_INT_TYPE, TCL_LL_MODIFIER, struct Tcl_StatBuf): Define for
Cygwin.
* generic/tclEnv.c (Tcl_CygwinPutenv): putenv replacement for Cygwin.
* generic/tclFileName.c (Tcl_TranslateFileName): Convert POSIX to
native format.
(TclDoGlob): Likewise.
* generic/tclPlatDecls.h (TCHAR): Define for Cygwin.
* win/tclWinPort.h (putenv, TclpSysAlloc, TclpSysFree)
(TclpSysRealloc): Define for Cygwin.
2002-09-26 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: preserve environment value of INSTALL_ROOT. When
embedding only use deployment build. Force relink before embedded
build to ensure new linker flags are picked up.
* macosx/Tcl.pbproj/project.pbxproj: add symbolic links to debug lib,
stub libs and tclConfig.sh in framework toplevel. Configure target
dependency fix. Fix to 'clean' action. Added private tcl headers to
framework. Install tclsh symbolic link. Html doc build works when no
installed tclsh available. Made html doc structure in framework more
like in Apple frameworks.
2002-09-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* unix/tcl.m4 (SC_TCL_64BIT_FLAGS): Yet more robust 64-bit value
detection to close [Bug 613117] on more systems.
* generic/tclCompile.c (TclPrintSource): More CONSTifying.
* generic/tclExecute.c (EvalStatsCmd): Object-ify to reduce warnings.
Thanks to 'CoderX2' on the chat for bringing this to my attention...
* unix/tcl.m4: Forgot to define TCL_WIDE_INT_IS_LONG at the
appropriate moment. I believe this is the cause of [Bug 613117]
* doc/lset.n: Changed 'list' to 'varName' for consistency with lappend
documentation. Thanks to Glenn Jackman [Bug 611719]
2002-09-22 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Corrected [puts -nonewline] within
test bodies. Thanks to Harald Kirsch. [Bug 612786, Patch 612788] Also
corrected reporting of body return code. Thanks to David Taback [Bug
611922]
* library/tcltest/pkgIndex.tcl: Bump to version 2.2.1.
* tests/tcltest.test: added tests for these bugs.
2002-09-15 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Add PEEK_XCLOSEIM define under
Linux. This is used by Tk to double check that an X input context is
cleaned up before it is closed.
2002-09-12 David Gravereaux <davygrvy@pobox.com>
* win/coffbase.txt: Added BLT to the virtual base address listings
table should BLT's build tools decide to use it.
2002-09-12 Daniel Steffen <das@users.sourceforge.net>
* generic/tcl.h:
* mac/tclMacApplication.r:
* mac/tclMacLibrary.r:
* mac/tclMacResource.r: unified use of the two equivalent resource
compiler header inclusion defines RC_INVOKED and RESOURCE_INCLUDED,
now use RC_INVOKED throughout.
2002-09-10 Mo DeJong <mdejong@users.sourceforge.net>
* unix/README: Add note about building extensions with the same
compiler Tcl was built with. [Tk Bug 592096]
2002-09-10 Daniel Steffen <das@users.sourceforge.net>
* macosx/Tcl.pbproj/project.pbxproj: disabled building html
documentation during embedded build.
2002-09-10 Daniel Steffen <das@users.sourceforge.net>
* unix/Makefile.in: added DYLIB_INSTALL_DIR variable for macosx and
set it to default value ${LIB_RUNTIME_DIR}
* unix/tcl.m4 (Darwin): use DYLIB_INSTALL_DIR instead of
LIB_RUNTIME_DIR in the -install_name argument to ld.
* unix/configure: regen.
* macosx/Tcl.pbproj/project.pbxproj:
* macosx/Makefile: added support for building Tcl as an embedded
framework, i.e. using an dyld install_name containing
@executable_path/../Frameworks via the new DYLIB_INSTALL_DIR
unix/Makefile variable.
2002-09-10 Jeff Hobbs <jeffh@ActiveState.com>
*** 8.4.0 TAGGED FOR RELEASE ***
2002-09-06 Don Porter <dgp@users.sourceforge.net>
* doc/file.n: Format correction, and clarified [file normalize]
|
| ︙ | ︙ | |||
1690 1691 1692 1693 1694 1695 1696 | 2002-09-05 Don Porter <dgp@users.sourceforge.net> * doc/tcltest.n: Clarified phrasing. * generic/tclBasic.c (TclRenameCommand,CallCommandTraces): * tests/trace.test (trace-27.1): Corrected memory leak when a rename | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | < | | | | | | < | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | < | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < | | < | | < | | < | < | | | | | | | | < | | | | > | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 7004 7005 7006 7007 7008 7009 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 7143 7144 7145 7146 7147 7148 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 |
2002-09-05 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n: Clarified phrasing.
* generic/tclBasic.c (TclRenameCommand,CallCommandTraces):
* tests/trace.test (trace-27.1): Corrected memory leak when a rename
trace deleted the command being traced. Test added. Thanks to Hemang
Lavana for the fix. [Bug 604609]
* generic/tclVar.c (TclDeleteVars): Corrected logic for setting the
TCL_INTERP_DESTROYED flag when calling variable traces. [Tk Bug 605121]
2002-09-04 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c (DeleteArray): leak plug [Bug 604239]. Thanks to
dkf and dgp for the long and difficult discussion in the chat.
2002-09-03 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclVar.c (Tcl_UpVar2): code cleanup to not use goto
* unix/configure: remove -pthread from LIBS on FreeBSD in thread
* unix/tcl.m4: enabled build. [Bug 602849]
2002-09-03 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclInterp.c (AliasCreate): a Tcl_Obj was leaked on error
return from TclPreventAliasLoop.
2002-09-03 Daniel Steffen <das@users.sourceforge.net>
* macosx/Tcl.pbproj/project.pbxproj: Bumped version number to 8.4.0
and updated copyright info.
2002-09-03 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c (Tcl_UpVar2): a Tcl_Obj was being leaked on error
return from TclGetFrame.
2002-09-03 Don Porter <dgp@users.sourceforge.net>
* changes: Updated changes for 8.4.0 release.
2002-09-02 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixFile.c (TclpObjLink): removed unnecessary/unfreed
extra native char*.
* unix/tclUnixChan.c (Tcl_MakeTcpClientChannel): make sure to init
flags field of TcpState ptr to 0.
* unix/configure:
* unix/tcl.m4: added 64-bit gcc compilation support on HP-11.
[Patch 601051] (martin)
* README: Bumped version number to 8.4.0
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure:
* win/configure.in:
* generic/tclInterp.c (SlaveCreate): make sure that the memory and
checkmem commands are initialized in non-safe slave interpreters when
TCL_MEM_DEBUG is used. [Bug 583445]
* win/tclWinConsole.c (ConsoleCloseProc): only wait on writable pipe
if there was something to write. This may prevent infinite wait on
exit.
* tests/exec.test: marked exec-18.1 unixOnly until the Windows
incompatability (in the test, not the core) can be resolved.
* tests/http.test (http-3.11): added close $fp that was causing an
error on Windows because the file was not closed before deleting.
* unix/tclUnixInit.c (Tcl_MacOSXGetLibraryPath): made this static
function only appear when HAVE_CFBUNDLE is defined.
2002-08-31 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4: added TK_SHLIB_LD_EXTRAS analogue of existing
TCL_SHLIB_LD_EXTRAS for linker settings only used when linking Tk.
* unix/configure: regen
2002-08-31 Daniel Steffen <das@users.sourceforge.net>
*** macosx-8-4-branch merged into the mainline [Patch 602770] ***
* generic/tcl.decls: added new macosx specific entry to stubs table.
* tools/genStubs.tcl: added generation of platform guards for macosx.
This is a little more complex than it seems, because MacOS X IS "unix"
plus a little bit, for the purposes of Tcl. BUT unfortunately, Tk uses
"unix" to mean X11. So added platform keys for macosx (the little
added to "unix"), "aqua" and "x11" to distinguish these for Tk.
* generic/tcl.h: added a #ifnded RESOURCE_INCLUDED so that tcl.h can
be passed to the resource compiler.
* generic/tcl.h:
* generic/tclNotify.c: added a few Notifier procs, to be able to
modify more bits of the Tcl notifier dynamically. Required to get Mac
OS X Tk to live on top of the Tcl Unix threaded notifier. Changes the
size of the Tcl_NotifierProcs structure, but doesn't move any elements
around.
* unix/tclUnixNotfy.c: moved the call to Tcl_ConditionNotify till
AFTER we are done mucking with the pointer swap. Fixes cases where the
thread waiting on the condition wakes & accesses the waitingListPtr
before it gets reset, causing a hang.
* library/auto.tcl (tcl_findLibrary): added checking the directories
in the tcl_pkgPath for library files on macosx to enable support of
the standard Mac OSX library locations
* unix/Makefile.in:
* unix/configure.in:
* unix/tcl.m4: added MAC_OSX_DIR. Added PLAT_OBJS to the OBJS: there
are some MacOS X specific files now for Tcl, and when I get he
resource & applescript stuff ported over, and restore support for
FindFiles, etc, there will be a few more. Added LD_LIBRARY_PATH_VAR
configure variable to avoid having to set all possible LD_LIBRARY_PATH
analogues on all platforms. LD_LIBRARY_PATH_VAR is "LD_LIBRARY_PATH"
by default, "LIBPATH" on AIX, "SHLIB_PATH" on HPUX and
"DYLD_LIBRARY_PATH" on Mac OSX. Added configure option to package Tcl
as a framework on Mac OSX.
* macosx/tclMacOSXBundle.c (new): support for finding Tcl extension
packaged as 'bundles' in the standard Mac OSX library locations.
* unix/tclUnixInit.c: added support for findig the tcl script library
inside Tcl packaged as a framework on Mac OSX.
* macosx/Tcl.pbproj/jingham.pbxuser (new):
* macosx/Tcl.pbproj/project.pbxproj (new): project for Apple's
ProjectBuilder IDE.
* macosx/Makefile (new): simple makefile for building the project from
the command line via the ProjectBuilder tool 'pbxbuild'.
* unix/configure:
* generic/tclStubInit.c:
* generic/tclPlatDecls.h: regen
2002-08-29 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* win/tclWinThrd.c (TclpFinalizeThreadData, TclWinFreeAllocCache):
Applied patch for [Bug 599428] (sofer)
2002-08-28 David Gravereaux <davygrvy@pobox.com>
* generic/tclEnv.c:
* unix/configure.in:
* win/tclWinPort.h: putenv() on some systems copies the buffer rather
than taking reference to it. This causes memory leaks and is know to
effect mswindows (msvcrt) and NetBSD 1.5.2. This patch tests for this
behavior and turns on -DHAVE_PUTENV_THAT_COPIES=1 when approriate.
Thanks to David Welton for assistance. [Bug 414910]
* unix/configure: regen'd
2002-08-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/eval.n: Added mention of list command and corrected "SEE ALSO".
* unix/configure.in: Cache handling of ac_cv_type_socklen_t was wrong.
[Bug 600931] reported by John Ellson. Fixed by putting the brackets
where they belong.
2002-08-26 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompCmds.c: fix for [Bug 599788] (error in element name
causing segfault), reported by Tom Wilkason. Fixed by copying the
tokens instead of the source string.
2002-08-26 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclThreadAlloc.c: small optimisation, reducing the new
allocator's overhead.
2002-08-23 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclObj.c (USE_THREAD_ALLOC): fixed leak [Bug 597936]. Thanks
to Zoran Vasiljevic.
2002-08-23 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclThreadAlloc.c (USE_THREAD_ALLOC): moving objects between
caches as a block, instead of one-by-one.
2002-08-22 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c:
* generic/tclCmdMZ.c: fix for freed memory r/w in delete traces [Bug
589863], patch by Hemang Lavana.
2002-08-20 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* win/Makefile.in (CFLAGS):
* unix/Makefile.in (MEM_DEBUG_FLAGS): Added usage of @MEM_DEBUG_FLAGS@.
* win/configure.in:
* unix/configure.in: Added usage of SC_ENABLE_MEMDEBUG.
* win/tcl.m4:
* unix/tcl.m4: Added macro SC_ENABLE_MEMDEBUG. Allows a user of
configure to (de)activate memory validation and debugging
(TCL_MEM_DEBUG). No need to modify the makefile anymore.
2002-08-20 Don Porter <dgp@users.sourceforge.net>
* generic/tclCkalloc.c: CONSTified MemoryCmd and CheckmemCmd.
* README: Bumped version number to 8.4b3 to distinguish
* generic/tcl.h: HEAD from the 8.4b2 release.
* tools/tcl.wse.in:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure.in:
* unix/configure: autoconf
* win/configure:
* library/http/http.tcl: Corrected installation directory of
* library/msgcat/msgcat.tcl: the package tcltest 2.2. Added
* library/opt/optparse.tcl: comments in other packages to remind
* library/tcltest/tcltest.tcl: that installation directories need
* unix/Makefile.in: updates to match increasing version
* win/Makefile.in: numbers. [Bug 597450]
* win/makefile.bc:
* win/makefile.vc:
2002-08-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* unix/tclUnixTest.c (TestfilehandlerCmd): Changed
readable/writable to the more common readable|writable.
Fixes [Bug 596034] (lvirden)
2002-08-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/fCmd.test: Added test to make sure that the cause of the
problem is detectable with an unpatched Tcl.
* doc/ObjectType.3: Added note on the root cause of this problem to
the documentation, since it is possible for user code to trigger this
sort of behaviour too.
* generic/tclIOUtil.c (SetFsPathFromAny): Objects should only have
their old representation deleted when we know that we are about to
install a new one. This stops a weird TclX bug under Linux with
certain kinds of memory debugging enabled which essentally came down
to a double-free of a string.
2002-08-14 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclInt.h:
* generic/tclObj.c: (code cleanup) factored the parts in the macros
TclNewObj() / TclDecrRefCount() into a common part for all memory
allocators and two new macros TclAllocObjStorage() /
TclFreeObjStorage() that are specific to each allocator and fully
describe the differences. Removed allocator-specific code from
tclObj.c by using the macros.
2002-08-12 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCmdMZ.c: fixing UMR in delete traces, [Bug 589863].
2002-08-08 David Gravereaux <davygrvy@pobox.com>
* tools/man2help.tcl: Fixed $argv handling bug where if -bitmap wasn't
specified $argc was off by one.
2002-08-08 Miguel Sofer <msofer@users.sourceforge.net>
* tests/uplevel.test: added 6.1 to test [uplevel] with shadowed
commands [Bug 524383]
* tests/subst.test: added 5.8-10 as further tests for [Bug 495207]
2002-08-08 Don Porter <dgp@users.sourceforge.net>
* tests/README: Noted removal of defs.tcl.
2002-08-08 Jeff Hobbs <jeffh@ActiveState.com>
* doc/lsearch.n: corrected lsearch docs to use -inline in examples.
*** 8.4b2 TAGGED FOR RELEASE ***
* tests/fCmd.test:
* tests/unixFCmd.test: updated tests for new link copy behavior.
* generic/tclFCmd.c (CopyRenameOneFile): changed the behavior to
follow links to endpoints and copy that file/directory instead of just
copying the surface link. This means that trying to copy a link that
has no endpoint (danling link) is an error. [Patch 591647] (darley)
(CopyRenameOneFile): this is currently disabled by default until
further issues with such behavior (like relative links) can be handled
correctly.
* tests/README: slight wording improvements
2002-08-07 Miguel Sofer <msofer@users.sourceforge.net>
* docs/BoolObj.3: added description of valid string reps for a boolean
object [Bug 584794]
* generic/tclObj.c: optimised Tcl_GetBooleanFromObj and
SetBooleanFromAny to avoid parsing the string rep when it can be
avoided [Bugs 584650, 472576]
2002-08-07 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompile.h:
* generic/tclObj.c: making tclCmdNameType static [Bug 584567] (dgp)
2002-08-07 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclObj.c (Tcl_NewObj): added conditional code for
USE_THREAD_ALLOC; objects allocated through Tcl_NewObj() were
otherwise being leaked. [Bug 587488] reported by Sven Sass.
2002-08-06 Daniel Steffen <das@users.sourceforge.net>
* generic/tclInt.decls:
* unix/tclUnixThrd.c: Added stubs and implementations for non-threaded
build for the tclUnixThrd.c procs TclpReaddir, TclpLocaltime,
TclpGmtime and TclpInetNtoa. Fixes link errors in stubbed & threaded
extensions that include tclUnixPort.h and use any of the procs
readdir, localtime, gmtime or inet_ntoa (e.g. TclX 8.4) [Bug 589526]
* generic/tclIntPlatDecls.h:
* generic/tclStubInit.c: Regen.
2002-08-05 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: The setup and cleanup scripts are now
* library/tcltest/pkgIndex.tcl: skipped when a test is skipped, fixing
* tests/tcltest.test: [Bug 589859]. Test for bug added, and
corrected tcltest package bumped to version 2.2.
* generic/tcl.decls: Restored Tcl_Concat to return (char *). Like
* generic/tclDecls.h: Tcl_Merge, it transfers ownership of a dynamic
* generic/tclUtil.c: allocated string to the caller.
2002-08-04 Don Porter <dgp@users.sourceforge.net>
* doc/CmdCmplt.3: Applied Patch 585105 to fully CONST-ify
* doc/Concat.3: all remaining public interfaces of Tcl.
* doc/CrtCommand.3: Notably, the parser no longer writes on
* doc/CrtSlave.3: the string it is parsing, so it is no
* doc/CrtTrace.3: longer necessary for Tcl_Eval() to be
* doc/Eval.3: given a writable string. Also, the
* doc/ExprLong.3: refactoring of the Tcl_*Var* routines
* doc/LinkVar.3: by Miguel Sofer is included, so that the
* doc/ParseCmd.3: "part1" argument for them no longer needs
* doc/SetVar.3: to be writable either.
* doc/TraceVar.3:
* doc/UpVar.3: Compatibility support has been enhanced so
* generic/tcl.decls: that a #define of USE_NON_CONST will remove
* generic/tcl.h: all possible source incompatibilities with
* generic/tclBasic.c: the 8.3 version of the header file(s).
* generic/tclCmdMZ.c: The new #define of USE_COMPAT_CONST now does
* generic/tclCompCmds.c:what USE_NON_CONST used to do -- disable
* generic/tclCompExpr.c:only those new CONST's that introduce
* generic/tclCompile.c: irreconcilable incompatibilities.
* generic/tclCompile.h:
* generic/tclDecls.h: Several bugs are also fixed by this patch.
* generic/tclEnv.c: [Bugs 584051,580433] [Patches 585105,582429]
* generic/tclEvent.c:
* generic/tclInt.decls:
* generic/tclInt.h:
* generic/tclIntDecls.h:
* generic/tclInterp.c:
* generic/tclLink.c:
* generic/tclObj.c:
* generic/tclParse.c:
* generic/tclParseExpr.c:
* generic/tclProc.c:
* generic/tclTest.c:
* generic/tclUtf.c:
* generic/tclUtil.c:
* generic/tclVar.c:
* mac/tclMacTest.c:
* tests/expr-old.test:
* tests/parseExpr.test:
* unix/tclUnixTest.c:
* unix/tclXtTest.c:
* win/tclWinTest.c:
2002-08-01 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: bugfix (reading freed memory). Testsuite
passed on linux/i386, compile-13.1 hung on linux/alpha.
2002-08-01 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: added a reference count for the complete
execution stack, instead of Tcl_Preserve/Tcl_Release.
2002-08-01 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tclCkalloc.c (TclFinalizeMemorySubsystem): Don't lock the
ckalloc mutex before invoking the Tcl_DumpActiveMemory function since
it also locks the same mutex. This code is only executed when "memory
onexit filename" has been executed and Tcl is compiled with
-DTCL_MEM_DEBUG.
2002-08-01 Reinhard Max <max@suse.de>
* win/tclWinPort.h: The windows headers don't provide socklen_t, so we
have to do it.
2002-07-31 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclInt.h (USE_THREAD_ALLOC): for unshared objects,
TclDecrRefCount now frees the internal rep before the string rep -
just like the non-macro Tcl_DecrRefCount/TclFreeObj [Bug 524802]. For
the other allocators the fix was done on 2002-03-06.
2002-07-31 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclInterp.c: signed/unsigned comparison warning fixed
(Vince Darley).
2002-07-31 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* unix/tcl.m4 (SC_BUGGY_STRTOD): Enabled caching of test results.
* unix/tcl.m4 (SC_BUGGY_STRTOD): Solaris 2.8 still has a buggy
strtod() implementation; make sure we detect it.
* tests/expr.test (expr-22.*): Marked as non-portable because it seems
that these tests have an annoying tendency to fail in unexpected ways.
[Bugs 584825, 584950, 585986]
2002-07-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* tests/io.test:
* generic/tclIO.c (WriteChars): Added flag to break out of loop if
nothing of the input is consumed at all, to prevent infinite looping
of called with a non-UTF-8 string. Fixes [Bug 584603] partially.
Added new test "io-60.1". Might need additional changes to Tcl_Main so
that unprintable results are printed as binary data.
2002-07-29 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in: Use CC_SEARCH_FLAGS instead of LD_SEARCH_FLAGS
when linking with ${CC}.
* unix/configure: Regen.
* unix/configure.in: Don't subst CC_SEARCH_FLAGS or LD_SEARCH_FLAGS
since this is now done in tcl.m4.
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Document and set CC_SEARCH_FLAGS
whenever LD_SEARCH_FLAGS is set. [Patch 588290]
2002-07-29 Reinhard Max <max@suse.de>
* unix/tcl.m4 (SC_SERIAL_PORT): Fixed detection for cases when
configure's stdin is not a tty.
* unix/tclUnixPort.h:
* generic/tclIOSock.c: Changed size_t to socklen_t in
socket-related function calls.
* unix/configure.in: Added test and fallback definition
for socklen_t.
* unix/configure: generated.
2002-07-29 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclObj.c: fixed a comment
* generic/tcl.h:
* generic/tclBasic.c:
* generic/tclInterp.c: added the new flag TCL_EVAL_INVOKE to the
interface of the Tcl_Eval* functions, removing the
TCL_EVAL_NO_TRACEBACK added yesterday: alias invocations not only
require no tracebacks, but also look up the command name in the global
scope - see new test interp-9.4
* tests/interp.test: added 9.3 to test for safety of aliases to hidden
commands, 9.4 to test for correct command lookup scope.
2002-07-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/regc_locale.c (cclass): [[:xdigit:]] is only a defined
concept on western characters, so should not allow any unicode digit,
and hence number of ranges in [[:xdigit:]] is fixed.
* tests/reg.test: Added test to detect the bug.
* generic/regc_cvec.c (newcvec): Corrected initial size value in
character vector structure. [Bug 578363] Many thanks to
pvgoran@users.sf.net for tracking this down.
2002-07-28 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tcl.h:
* generic/tclBasic.c: added the new flag TCL_EVAL_NO_TRACEBACK to the
interface of the Tcl_Eval* functions. Modified the error message for
too many nested evaluations.
* generic/tclInterp.h: changed the Alias struct to be of variable
length and store the prefix arguments directly (instead of a pointer
to a Tcl_Obj list). Made AliasObjCmd call Tcl_EvalObjv instead of
TclObjInvoke - thus making aliases trigger execution traces. [Bug
582522]
* tests/interp.test:
* tests/stack.test: adapted to the new error message.
* tests/trace.test: added tests for aliases firing the exec traces.
2002-07-27 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in: Revert fix for Tcl bug 529801 since it was
incorrect and broke the build on other systems. Fix [Bug 587299]. Add
MAJOR_VERSION, MINOR_VERSION, PATCH_LEVEL, SHLIB_LD_FLAGS,
SHLIB_LD_LIBS, CC_SEARCH_FLAGS, LD_SEARCH_FLAGS, and LIB_FILE
variables to support more generic library build/install rules.
* unix/configure: Regen.
* unix/configure.in: Move AC_PROG_RANLIB into tcl.m4. Move shared
build test and setting of MAKE_LIB and MAKE_STUB_LIB into tcl.m4. Move
subst of a number of variables into tcl.m4 where they are defined.
* unix/tcl.m4 (SC_ENABLE_SYMBOLS, SC_CONFIG_CFLAGS):
Subst vars where they are defined. Add MAKE_LIB, MAKE_STUB_LIB,
INSTALL_LIB, and INSTALL_STUB_LIB rules to deal with the ugly details
of running ranlib on static libs at build and install time. Replace
TCL_SHLIB_LD_EXTRAS with SHLIB_LD_FLAGS and use it when building a
shared library.
* unix/tclConfig.sh.in: Add TCL_CC_SEARCH_FLAGS.
2002-07-26 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: fixed Tcl_Obj leak in code corresponding to
the macro NEXT_INST_V(x, 0, 1). [Bug 587495]
2002-07-26 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c (TclObjLookupVar): leak fix and improved comments.
2002-07-26 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclVar.c (TclLookupVar): removed early returns that
prevented the parens from being restored. also removed goto label as
it was not necessary.
2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c:
* tests/expr-old.test: fix for erroneous error messages in [expr],
[Bug 587140] reported by Martin Lemburg.
2002-07-25 Joe English <jenglish@users.sourceforge.net>
* generic/tclProc.c: fix for [Tk Bug 219218] "error handling with
bgerror in Tk"
2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: restoring full TCL_COMPILE_DEBUG
functionality.
2002-07-24 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test: relaxed unixInit-3.1 to accept iso8859-15 as a
valid C encoding. [Bug 575336]
2002-07-24 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: restoring the tcl_traceCompile functionality
while I repair tcl_traceExec. The core now compiles and runs also
under TCL_COMPILE_DEBUG, but execution in the bytecode engine can
still not be traced.
2002-07-24 Daniel Steffen <das@users.sourceforge.net>
* unix/Makefile.in:
* unix/configure.in: corrected fix for [Bug 529801]: ranlib only
needed for static builds on Mac OS X.
* unix/configure: Regen.
* unix/tclLoadDyld.c: fixed small bugs introduced by Vince,
implemented library unloading correctly (needs OS X 10.2).
2002-07-23 Joe English <jenglish@users.sourceforge.net>
* doc/OpenFileChnl.3: (Updates from Larry Virden)
* doc/open.n:
* doc/tclsh.1: Fix section numbers in Unix man page references.
* doc/lset.n: In EXAMPLES section, include command to set the initial
value used in subsequent examples.
* doc/http.n: Package version updated to 2.4.
2002-07-23 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Enable 64 bit compilation when using
the native compiler on a 64 bit version of IRIX. [Bug 219220]
2002-07-23 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in: Combine ranlib tests and avoid printing unless
ranlib is actually run.
2002-07-23 Mo DeJong <mdejong@users.sourceforge.net>
* unix/tcl.m4 (SC_PATH_X): Set XINCLUDES to "" instead of "# no
special path needed" or "# no include files found" when x headers
cannot be located.
2002-07-22 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c: made tclNativeFilesystem static (since 07-19
changes removed its usage elsewhere), and added comments about its
usage.
* generic/tclLoad.c:
* generic/tcl.h:
* generic/tcl.decls:
* doc/FileSystem.3: converted last load-related ClientData parameter
to Tcl_LoadHandle opaque structure, removing a couple of casts in the
process.
* generic/tclInt.h: removed tclNativeFilesystem declaration since it
is now static again.
2002-07-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/expr.test (expr-22.*): Added tests to help detect the
corrected handling.
* generic/tclExecute.c (IllegalExprOperandType): Improved error
message generated when attempting to manipulate Inf and NaN values.
* generic/tclParseExpr.c (GetLexeme): Allowed parser to recognise
'Inf' as a floating-point number. [Bug 218000]
2002-07-21 Don Porter <dgp@users.sourceforge.net>
* tclIOUtil.c: Silence compiler warning. [Bug 584408].
2002-07-19 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c: fix to GetFilesystemRecord
* win/tclWinFile.c:
* unix/tclUnixFile.c: fix to subtle problem with links shown up by
latest tclkit builds.
2002-07-19 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure:
* unix/configure.in:
* win/configure:
* win/configure.in: Add AC_PREREQ(2.13) in an attempt to make it more
clear that the configure scripts must be generated with autoconf
version 2.13. [Bug 583573]
2002-07-19 Vince Darley <vincentdarley@users.sourceforge.net>
* unix/Makefile.in: fix to build on MacOS X [Bug 529801], bug report
and fix from jcw.
2002-07-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* win/tclWinSerial.c (no_timeout): Made this variable static.
* generic/tclExecute.c, generic/tclCompile.c, generic/tclBasic.c:
* generic/tclCompile.h (builtinFuncTable, instructionTable): Added
prefix to these symbols because they are visible outside the Tcl
library.
* generic/tclCompExpr.c (operatorTable):
* unix/tclUnixTime.c (tmKey):
* generic/tclIOUtil.c (theFilesystemEpoch, filesystemWantToModify,
(filesystemIteratorsInProgress, filesystemOkToModify): Made these
variables static.
* unix/tclUnixFile.c: Renamed nativeFilesystem to
* win/tclWinFile.c: tclNativeFilesystem and declared
* generic/tclIOUtil.c: it properly in tclInt.h
* generic/tclInt.h:
* generic/tclUtf.c (totalBytes): Made this array static and const.
* generic/tclParse.c (typeTable): Made this array static and const.
(Tcl_ParseBraces): Simplified error handling case so that scans are
only performed when needed, and flags are simpler too.
* license.terms: Added AS to list of copyright holders; it's only fair
for the current gatekeepers to be listed here!
* tests/cmdMZ.test: Renamed constraint for clarity. [Bug 583427]
Added tests for the [time] command, which was previously only
indirectly tested!
2002-07-18 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclInt.h:
* generic/tcl.h:
* */*Load*.c: added comments on changes of 07/17 and replaced
clientData with Tcl_LoadHandle in all locations.
* generic/tclFCmd.c:
* tests/fileSystem.test: fixed a 'knownBug' with 'file
attributes ""'
* tests/winFCmd.test:
* tests/winPipe.test:
* tests/fCmd.test:
* tessts/winFile.test: added 'pcOnly' constraint to some tests to make
for more useful 'tests skipped' log from running all tests on
non-Windows platforms.
2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c (CallCommandTraces): delete traces now receive
the FQ old name of the command. [Bug 582532] (Don Porter)
2002-07-18 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/ioUtil.test: added constraints to 1.4,2.4 so they don't run
outside of tcltest. [Bugs 583276,583277]
2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c (DupParsedVarName): nasty bug fixed, reported by
Vince Darley.
2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c (TclPtrIncrVar): missing CONST in declarations,
inconsistent with tclInt.h. Thanks to Vince Darley for reporting, boo
to gcc for not complaining.
2002-07-17 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclInt.h:
* generic/tclIOUtil.c:
* generic/tclLoadNone.c:
* unix/tclLoadAout.c:
* unix/tclLoadDl.c:
* unix/tclLoadDld.c:
* unix/tclLoadDyld.c:
* unix/tclLoadNext.c:
* unix/tclLoadOSF.c:
* unix/tclLoadShl.c:
* mac/tclMacLoad.c:
* win/tclWinLoad.c: modified to move more functionality to the generic
code and avoid duplication. Partial replacement of internal uses of
clientData with opaque Tcl_LoadHandle. A little further work still
needed, but significant changes are done.
2002-07-17 D. Richard Hipp <drh@hwaci.com>
* library/msgcat/msgcat.tcl: fix a comment that was causing problems
for programs (ex: mktclapp) that embed the initialization scripts in
strings.
2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclInt.decls:
* generic/tclIntDecls.h:
* generic/tclStubInit.c:
* generic/tclVar.c: removing the now redundant functions to access
indexed variables: Tcl(Get|Set|Incr)IndexedScalar() and
Tcl(Get|Set|Incr)ElementOfIndexedArray().
2002-07-17 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclExecute.c (TclExecuteByteCode): Minor fixes to make this
file compile with SunPro CC...
2002-07-17 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: modified to do variable lookup explicitly, and
then either inlining the variable access or else calling the new
TclPtr(Set|Get|Incr)Var functions in tclVar.c
* generic/tclInt.h: declare some functions previously local to
tclVar.c for usage by TEBC.
* generic/tclVar.c: removed local declarations; moved all special
accessor functions for indexed variables to the end of the file - they
are unused and ready for removal, but left there for the time being as
they are in the internal stubs table.
** WARNING FOR BYTECODE MAINTAINERS **
TCL_COMPILE_DEBUG is currently not functional; will be fixed ASAP.
2002-07-16 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in:
* win/Makefile.in: Add a more descriptive warning in the event `make
genstubs` needs to be rerun.
2002-07-16 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in: Use dltest.marker file to keep track of when the
dltest package is up to date. This fixes [Bug 575768] since tcltest is
no longer linked every time.
* unix/dltest/Makefile.in: Create ../dltest.marker after a successful
`make all` run in dltest.
2002-07-16 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/configure.in: Remove useless subst of TCL_BIN_DIR.
2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c: inaccurate comment fixed
2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c (Tcl_AddObjErrorInfo):
* generic/tclExecute.c (TclUpdateReturnInfo):
* generic/tclInt.h:
* generic/tclProc.c:
Added two Tcl_Obj to the ExecEnv structure to hold the fully qualified
names "::errorInfo" and "::errorCode" to cache the addresses of the
corresponding variables. The two most frequent setters of these
variables now profit from the new variable name caching.
2002-07-15 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c: refactorisation to reuse already looked-up Var
pointers; definition of three new Tcl_Obj types to cache variable name
parsing and lookup for later reuse; modification of internal functions
to profit from the caching.
* generic/tclInt.decls:
* generic/tclInt.h:
* generic/tclIntDecls.h:
* generic/tclNamesp.c: adding CONST qualifiers to variable names
passed to Tcl_FindNamespaceVar and to variable resolvers; adding CONST
qualifier to the 'msg' argument to TclLookupVar. Needed to avoid code
duplication in the new tclVar.c code.
* tests/set-old.test:
* tests/var.test: slight modification of error messages due to the
modifications in the tclVar.c code.
2002-07-15 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test: Improved constraints to protect /tmp. [Bug
581403]
2002-07-15 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/winFCmd.test: renamed 'win2000' and 'notWin2000' to more
appropriate constraint names.
* win/tclWinFile.c: updated comments to reflect 07-11 changes.
* win/tclWinFCmd.c: made ConvertFileNameFormat static again, since no
longer used in tclWinFile.c
* mac/tclMacFile.c: completed TclpObjLink implementation which was
previously lacking.
* generic/tclIOUtil.c: comment cleanup and code speedup.
2002-07-14 Don Porter <dgp@users.sourceforge.net>
* generic/tclInt.h: Removed declarations that duplicated entries
in the (internal) stub table.
* library/tcltest/tcltest.tcl: Corrected errors in handling of
configuration options -constraints and -limitconstraints.
* README: Bumped HEAD to version 8.4b2 so we can
* generic/tcl.h: distinguish it from the 8.4b1 release.
* tools/tcl.wse.in:
* unix/configure*:
* unix/tcl.spec:
* win/README.binary:
* win/configure*:
2002-07-11 Vince Darley <vincentdarley@users.sourceforge.net>
* doc/file.n:
* win/tclWinFile.c: on Win 95/98/ME the long form of the path is used
as a normalized form. This is required because short forms are not a
robust representation. The file normalization function has been sped
up, but more performance gains might be possible, if speed is still an
issue on these platforms.
2002-07-11 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Corrected reaction to existing but
false ::tcl_interactive.
* doc/Hash.3: Overlooked CONST documentation update.
2002-07-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCkalloc.c: ckalloc() and friends take the block size as
an unsigned, so we should use %ud when reporting it in fprintf() and
panic().
2002-07-11 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompile.c: now setting local vars undefined at compile
time, instead of waiting until the proc is initialized.
* generic/tclProc.c: use macro TclSetVarUndefined instead of directly
setting the flag.
2002-07-11 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/cmdAH.test: [file attr -perm] is Unix-only, so add [catch]
when not inside a suitably-protected test.
2002-07-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/unixFCmd.test, tests/fileName.test:
* tests/fCmd.test: Removed [exec] of Unix utilities that have
equivalents in standard Tcl. [Bug 579268] Also simplified some of
unixFCmd.test while I was at it.
2002-07-10 Don Porter <dgp@users.sourceforge.net>
* tests/tcltest.test: Greatly reduced the number of [exec]s, using
slave interps instead.
* library/tcltest/tcltest.tcl: Fixed bug uncovered in the conversion
where a message was written to stdout instead of [outputChannel].
* tests/basic.test: Cleaned up, constrained, and reduced the
* tests/compile.test: amount of [exec] usage in the test suite.
* tests/encoding.test:
* tests/env.test:
* tests/event.test:
|
| ︙ | ︙ | |||
2637 2638 2639 2640 2641 2642 2643 | * tests/winPipe.test: 2002-07-10 Donal K. Fellows <fellowsd@cs.man.ac.uk> * tests/cmdAH.test: Removed [exec] of Unix utilities. [Bug 579211] * tests/expr.test: Added tests to make sure that this works. | | | | | | | | | | < | | > | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | < | | | | | | 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 7420 7421 7422 7423 7424 7425 7426 7427 7428 7429 7430 7431 7432 7433 7434 7435 7436 7437 7438 7439 7440 7441 7442 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 7458 7459 7460 7461 7462 7463 7464 7465 7466 7467 7468 7469 | * tests/winPipe.test: 2002-07-10 Donal K. Fellows <fellowsd@cs.man.ac.uk> * tests/cmdAH.test: Removed [exec] of Unix utilities. [Bug 579211] * tests/expr.test: Added tests to make sure that this works. * generic/tclExecute.c (ExprCallMathFunc): Functions should also be able to return wide-ints. [Bug 579284] 2002-07-08 Andreas Kupries <andreas_kupries@users.sourceforge.net> * tests/socket.test: Fixed [Bug 578164]. The original reason for the was a DNS outage while running the testsuite. Changed [info hostname] to 127.0.0.1 to bypass DNS, knowing that we operate on the local host. 2002-07-08 Don Porter <dgp@users.sourceforge.net> * doc/tcltest.n: Fixed incompatibility in [viewFile]. * library/tcltest/tcltest.tcl: Corrected docs. Bumped to 2.2.1. * library/tcltest/pkgIndex.tcl: [Bug 578163] 2002-07-08 Vince Darley <vincentdarley@users.sourceforge.net> * tests/cmdAH.test: * tests/fCmd.test: * tests/fileName.test: tests which rely on 'file link' need a constraint so they don't run on older Windows OS. [Bug 578158] * generic/tclIOUtil.c: * generic/tcl.h: * generic/tclInt.h: * generic/tclTest.c: * mac/tclMacChan.c: * unix/tclUnixChan.c: * win/tclWinChan.c: * doc/FileSystem.3: cleaned up internal handling of Tcl_FSOpenFileChannel to remove duplicate code, and make writing external vfs's clearer and easier. No functionality change. Also clarify that objects with refCount zero should not be passed in to the Tcl_FS API, and prevent segfaults from occuring on such user errors. [Bug 578617] 2002-07-06 Don Porter <dgp@users.sourceforge.net> * tests/pkgMkIndex.test: Constrained tests of [load] package indexing to those platforms where the testing shared libraries have been built. [Bug 578166]. 2002-07-05 Don Porter <dgp@users.sourceforge.net> * changes: added recent changes 2002-07-05 Reinhard Max <max@suse.de> * generic/tclClock.c (FormatClock): Convert the format string to UTF8 before calling TclpStrftime, so that non-ASCII characters don't get mangled when the result string is being converted back. * tests/clock.test: Added a test for that. 2002-07-05 Donal K. Fellows <fellowsd@cs.man.ac.uk> * unix/Makefile.in (ro-test,ddd,GDB,DDD): Created new targets to allow running the test suite with a read-only current directory, running under ddd instead of gdb, and factored out some executable names for broken sites (like mine) where gdb and ddd are installed with non-standard names... * tests/httpold.test: Altered test names to httpold-* to avoid clashes with http.test, and stopped tests from failing when the current directory is not writable... * tests/event.test: Stop these tests from failing * tests/ioUtil.test: when the current directory is * tests/regexp.test: not writable... * tests/regexpComp.test: * tests/source.test: * tests/unixFile.test: * tests/unixNotfy.test: * tests/unixFCmd.test: Trying to make these test-files * tests/macFCmd.test: not bomb out with an error when * tests/http.test: the current directory is not * tests/fileName.test: writable... * tests/env.test: 2002-07-05 Jeff Hobbs <jeffh@ActiveState.com> *** 8.4b1 TAGGED FOR RELEASE *** 2002-07-04 Donal K. Fellows <fellowsd@cs.man.ac.uk> * tests/cmdMZ.test (cmdMZ-1.4): * tests/cmdAH.test: More fixing of writable-current-dir assumption. [Bug 575824] 2002-07-04 Miguel Sofer <msofer@users.sourceforge.net> * tests/basic.test: Same issue as below; fixed [Bug 575817] 2002-07-04 Andreas Kupries <andreas_kupries@users.sourceforge.net> * tests/socket.test: * tests/winPipe.test: * tests/pid.test: Fixed [Bug 575848]. See below for a description the general problem. All the bugs below are instances of the same problem: The testsuite assumes [pwd] = [temporaryDirectory] and writable. * tests/iogt.test: Fixed [Bug 575860] * tests/io.test: Fixed [Bug 575862] * tests/exec.test: * tests/ioCmd.test: Fixed [Bug 575836] 2002-07-03 Don Porter <dgp@users.sourceforge.net> * tests/pkg1/direct1.tcl: removed * tests/pkg1/pkgIndex.tcl: removed * tests/pkgMkIndex.test: Imported auxilliary files from tests/pkg1 into the test file pkgMkIndex.test itself. Formatting fixes. * unix/Makefile.in: removed tests/pkg/* from `make dist` * tests/pkg/circ1.tcl: removed * tests/pkg/circ2.tcl: removed * tests/pkg/circ3.tcl: removed * tests/pkg/global.tcl: removed * tests/pkg/import.tcl: removed * tests/pkg/pkg1.tcl: removed * tests/pkg/pkg2_a.tcl: removed * tests/pkg/pkg2_b.tcl: removed * tests/pkg/pkg3.tcl: removed * tests/pkg/pkg4.tcl: removed * tests/pkg/pkg5.tcl: removed * tests/pkg/pkga.tcl: removed * tests/pkg/samename.tcl: removed * tests/pkg/simple.tcl: removed * tests/pkg/spacename.tcl: removed * tests/pkg/std.tcl: removed * tests/pkgMkIndex.test: Fixed [Bug 575857] where this test file expected to be able to write to [file join [testsDirectory] pkg]. Part of the fix was to import several auxilliary files into the test file itself. * tests/main.test: Cheap fix for [Bugs 575851, 575858]. Avoid * tests/tcltest.test: non-writable . by [cd [temporaryDirectory]]. * library/auto.tcl: Fix [tcl_findLibrary] to be sure it sets $varName only if a successful library script is found. [Bug 577033] 2002-07-03 Miguel Sofer <msofer@users.sourceforge.net> * generic/tclCompCmds.c (TclCompileCatchCmd): return TCL_OUT_LINE_COMPILE instead of TCL_ERROR: let the failure happen at runtime so that it can be caught [Bug 577015]. 2002-07-02 Joe English <jenglish@users.sourceforge.net> * doc/tcltest.n: Markup fixes, spellcheck. 2002-07-02 Don Porter <dgp@users.sourceforge.net> * doc/tcltest.n: more refinements of the documentation. * library/tcltest/tcltest.tcl: Added trace to be sure the stdio constraint is updated whenever the [interpreter] changes. * doc/tcltest.n: Reverted [makeFile] and [viewFile] to * library/tcltest/tcltest.tcl: their former behavior, and documented * tests/cmdAH.test: it. Corrected misspelling of hook * tests/event.test: procedure. Restored tests. * tests/http.test: * tests/io.test: * library/tcltest/tcltest.tcl: Simplified logic of [GetMatchingFiles] and [GetMatchingDirectories], removing special case processing. * doc/tcltest.n: More documentation updates. Reference sections are complete. Only examples need adding. 2002-07-02 Vince Darley <vincentdarley@users.sourceforge.net> * tests/fCmd.test: * generic/tclCmdAH.c: clearer error msgs for 'file link', as per the man page. 2002-07-01 Joe English <jenglish@users.sourceforge.net> * doc/Access.3: * doc/AddErrInfo.3: * doc/Alloc.3: * doc/Backslash.3: |
| ︙ | ︙ | |||
2854 2855 2856 2857 2858 2859 2860 | * doc/msgcat.n: * doc/packagens.n: * doc/pkgMkIndex.n: * doc/registry.n: * doc/resource.n: * doc/safe.n: * doc/scan.n: | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | < | | | | | > | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | < | | < | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | < | | | | | | | | | | | | | | | | | < | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | < | | | < | | | | | | | | | | | | < | | | | | | < | | | | | | | < | < | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | | | | < | | | | | | | | | | | | | | | | < | | | | < | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | < | | | | < | | | | | < | | | | | < | | | < | | | | < | | > | | | | | | < | 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 7541 7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 8257 8258 8259 8260 8261 8262 8263 8264 8265 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 8614 8615 8616 8617 8618 8619 8620 8621 8622 8623 8624 8625 8626 8627 8628 8629 8630 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 8676 8677 8678 8679 8680 8681 8682 8683 8684 8685 8686 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 8719 8720 8721 8722 8723 8724 8725 8726 8727 8728 8729 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 8782 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 8865 8866 8867 8868 8869 8870 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 8882 8883 8884 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 8939 8940 8941 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 |
* doc/msgcat.n:
* doc/packagens.n:
* doc/pkgMkIndex.n:
* doc/registry.n:
* doc/resource.n:
* doc/safe.n:
* doc/scan.n:
* doc/tclvars.n: Spell-check, fixed typos (Updates from Larry Virden)
2002-07-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Made Solaris use gcc for linking
when building with gcc to resolve problems with undefined symbols
being present when tcl library used with non-gcc linker at later
stage. Symbols were compiler-generated, so it is the compiler's
business to define them. [Bug 541181]
2002-07-01 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n: more work in progress updating tcltest docs.
* library/tcltest/tcltest.tcl: Change [configure -match] to stop
treating an empty list as a list of the single pattern "*". Changed
the default value to [list *] so default operation remains the same.
* tests/pkg/samename.tcl: restored. Needed by pkgMkIndex.test.
* library/tcltest/tcltest.tcl: restored writeability testing of
-tmpdir, augmented by a special exception for the deafault value.
2002-07-01 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/concat.n: Documented the *real* behaviour of [concat]!
2002-06-30 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n: more work in progress updating tcltest docs.
* tests/README: Updated the instructions on running and
* tests/cmdMZ.test: adding to the test suite. Also updated
* tests/encoding.test: several tests, mostly to correctly create
* tests/fCmd.test: and destroy any temporary files in the
* tests/info.test: [temporaryDirectory] of tcltest.
* tests/interp.test:
* library/tcltest/tcltest.tcl: Stopped checking for writeability of
-tmpdir value because no default directory can be guaranteed to be
writeable.
* tests/autoMkindex.tcl: removed.
* tests/pkg/samename.tcl: removed.
* tests/pkg/magicchar.tcl: removed.
* tests/pkg/magicchar2.tcl: removed.
* tests/autoMkindex.test: Updated auto_mkIndex tests to use [makeFile]
and [removeFile] so tests are done in [temporaryDirecotry] where write
access is guaranteed.
* library/tcltest/tcltest.tcl: Fixed [makeFile] and [viewFile] to
* tests/cmdAH.test: accurately reflect a file's contents.
* tests/event.test: Updated tests that depended on buggy
* tests/http.test: behavior. Also added warning messages
* tests/io.test: to "-debug 1" operations to debug test
* tests/iogt.test: calls to (make|remove)(File|Directory).
* unix/mkLinks: `make mklinks` on 6-27 commits.
2002-06-28 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompile.h: modified the macro TclEmitPush to not call its
first argument repeatedly or pass it to other macros, [Bug 575194]
reported by Peter Spjuth.
2002-06-28 Don Porter <dgp@users.sourceforge.net>
* docs/tcltest.n: Doc revisions in progress.
* library/tcltest/tcltest.tcl: Corrected -testdir default value. Was
not reliable, and disagreed with docs! Thanks to Hemang Lavana. [Bug
575150]
2002-06-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* unix/tclUnixThrd.c: Renamed the Tcl_Platform* #defines to
* unix/tclUnixPipe.c: TclOS* because they are only used
* unix/tclUnixFile.c: internally. Also stopped double-#def
* unix/tclUnixFCmd.c: of TclOSlstat [Bug 566099, post-rename]
* unix/tclUnixChan.c:
* unix/tclUnixPort.h:
* doc/string.n: Improved documentation for [string last] along lines
described in [Bug 574799] so it indicates that the supplied index
marks the end of the search space.
2002-06-27 Don Porter <dgp@users.sourceforge.net>
* doc/dde.n: Work in progress updating the documentation
* doc/http.n: of the packages that come bundled with
* doc/msgcat.n: the Tcl source distribution, notably tcltest.
* doc/registry.n:
* doc/tcltest.n:
* library/tcltest/tcltest.tcl: Made sure that the TCLTEST_OPTIONS
environment variablle configures tcltest at package load time.
2002-06-26 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/fileSystem.test:
* generic/tclIOUtil.c: fix to handling of empty paths "" which are not
claimed by any filesystem [Bug 573758]. Ensure good error messages are
given in all cases.
* tests/cmdAH.test:
* unix/tclUnixFCmd.c: fix to bug reported as part of [Patch 566669].
Thanks to Taguchi, Takeshi for the report.
2002-06-26 Reinhard Max <max@suse.de>
* unix/tclUnixTime.c: Make [clock format] respect locale settings.
* tests/clock.test: [Bug 565880]. ***POTENTIAL INCOMPATIBILITY***
2002-06-26 Miguel Sofer <msofer@users.sourceforge.net>
* doc/CrtInterp.3:
* doc/StringObj.3: clarifications by Don Porter, [Bugs 493995, 500930]
2002-06-24 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Corrected suppression of -verbose skip
* tests/tcltest.test: and start by [test -output]. Also
corrected test suite errors exposed by corrected code. [Bug 564656]
2002-06-25 Reinhard Max <max@suse.de>
* unix/tcl.m4: New macro SC_CONFIG_MANPAGES.
* unix/configure.in: Added support for symlinks and compression
* unix/Makefile.in: when installing the manpages. [Patch 518052]
* unix/mkLinks.tcl: Default is still hardlinks and no compression.
* unix/mkLinks: generated
* unix/configure:
* unix/README: Added documentation for the new features.
* unix/tcl.m4 (SC_PATH_TCLCONFIG): Replaced ${exec_prefix}/lib by
${libdir}.
2002-06-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclUtil.c (TclGetIntForIndex): Fix of critical [Bug 533364]
generated when the index is bad and the result is a shared object. The
T_ASTO(T_GOR, ...) idiom likely exists elsewhere though. Also removed
some cruft that just complicated things to no advantage.
(SetEndOffsetFromAny): Same fix, though this wasn't on the path
excited by the bug.
2002-06-24 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Implementation of TIP 101. Adds
* tests/parseOld.test: and exports a [configure] command
* tests/tcltest.test: from tcltest.
2002-06-22 Don Porter <dgp@users.sourceforge.net>
* changes: updated changes file for 8.4b1 release.
* library/tcltest/tcltest.tcl: Corrections to tcltest and the
* tests/basic.test: Tcl test suite so that a test
* tests/cmdInfo.test: with options -constraints knownBug
* tests/compile.test: -limitConstraints 1 only tests the
* tests/encoding.test: knownBug tests. Mostly involves
* tests/env.test: replacing direct access to the
* tests/event.test: testConstraints array with calls
* tests/exec.test: to the testConstraint command
* tests/execute.test: (which requires tcltest version 2)
* tests/fCmd.test:
* tests/format.test:
* tests/http.test:
* tests/httpold.test:
* tests/ioUtil.test:
* tests/link.test:
* tests/load.test:
* tests/namespace.test:
* tests/pkgMkIndex.test:
* tests/reg.test:
* tests/result.test:
* tests/scan.test:
* tests/stack.test:
2002-06-22 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tools/tcl.wse.in (Disk Label), unix/tcl.spec (version):
* win/README.binary, README, win/configure.in, unix/configure.in:
* generic/tcl.h (TCL_RELEASE_*, TCL_PATCH_LEVEL): Bump to beta1.
2002-06-21 Joe English <jenglish@users.sourceforge.net>
* generic/tclCompExpr.c:
* generic/tclParseExpr.c: LogSyntaxError() should reset the
interpreter result [Bug 550142 "Tcl_ExprObj -> abort"]
2002-06-21 Don Porter <dgp@users.sourceforge.net>
* unix/Makefile.in: Updated all package install directories to
* win/Makefile.in: match current Major.minor versions of the
* win/makefile.bc: packages. Added tcltest package to
* win/makefile.vc: installation on Windows.
* library/init.tcl: Corrected comments and namespace style issues.
Thanks to Bruce Stephens. [Bug 572025]
2002-06-21 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/cmdAH.test: Added TIP#99 implementation of 'file
* tests/fCmd.test: link'. Supports creation of symbolic and
* tests/fileName.test: hard links in the native filesystems and
* tests/fileSystem.test: in vfs's, when the individual filesystem
* generic/tclTest.c: supports the concept.
* generic/tclCmdAH.c:
* generic/tclIOUtil.c:
* generic/tcl.h:
* generic/tcl.decls:
* doc/FileSystem.3:
* doc/file.n:
* mac/tclMacFile.c:
* unix/tclUnixFile.c:
* win/tclWinFile.c: Also enhanced speed of 'file normalize' on Windows
2002-06-20 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c (TclEvalObjvInternal): fix for [Bug 571385] in
the implementation of TIP#62 (command tracing). Vince Darley, Hemang
Lavana & Don Porter: thanks.
2002-06-20 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c (TclCompEvalObj): clarified and simplified the
logic for compilation/recompilation.
2002-06-19 Joe English <jenglish@users.sourceforge.net>
* doc/file.n: Fixed indentation. No substantive changes.
2002-06-19 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclCmdMZ.c (Tcl_RegexpObjCmd): get the resultPtr again as
the Tcl_ObjSetVar2 may cause the result to change.
[Patch 558324] (watson)
2002-06-19 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c (TEBC): removing unused "for(;;)" loop;
improved comments; re-indentation.
2002-06-18 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c (TEBC):
- elimination of duplicated code in the non-immediate INST_INCR
instructions.
- elimination of 103 (!) TclDecrRefCount macros. The different
instructions now jump back to a common "DecrRefCount zone" at the
top of the loop. The macro "ADJUST_PC" was replaced by two macros
"NEXT_INST_F" and "NEXT_INST_V" that take three params
(pcAdjustment, # of stack objects to discard, resultObjPtr handling
flag). The only instructions that retain a TclDecrRefCount are
INST_POP (for speed), the common code for the non-immediate
INST_INCR, INST_FOREACH_STEP and the two INST_LSET.
The object size of tclExecute.o was reduced by approx 20% since the
start of the consolidation drive, while making room for some peep-hole
optimisation at runtime.
2002-06-18 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c (TEBC, INST_DONE): small bug in the panic code
for tcl-stack corruption.
2002-06-17 David Gravereaux <davygrvy@pobox.com>
Trims to support the removal of RESOURCE_INCLUDED from rc scripts from
[FRQ 565088].
* generic/tcl.h: moved the #ifndef RC_INVOKED start block up in the
file. rc scripts don't need to know thread mutexes.
* win/tcl.rc:
* win/tclsh.rc: removed the #define RESOURCE_INCLUDED to let the
built-in -DRC_INVOKED to the work.
2002-06-17 Jeff Hobbs <jeffh@ActiveState.com>
* doc/CrtTrace.3: Added TIP#62 implementation of command
* doc/trace.n: execution tracing [FRQ 462580] (lavana).
* generic/tcl.h: This includes enter/leave tracing as well
* generic/tclBasic.c: as inter-procedure stepping.
* generic/tclCmdMZ.c:
* generic/tclCompile.c:
* generic/tclExecute.c:
* generic/tclInt.decls:
* generic/tclInt.h:
* generic/tclIntDecls.h:
* generic/tclStubInit.c:
* generic/tclVar.c:
* tests/trace.test:
2002-06-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* win/tclWinPipe.c (BuildCommandLine): Fixed [bug 554068] ([exec] on
windows did not treat { in filenames well.). Bug reported by Vince
Darley <vincentdarley@users.sourceforge.net>, patch provided by Vince
too.
2002-06-17 Joe English <jenglish@users.sourceforge.net>
* generic/tcl.h: #ifdef logic for K&R C backwards compatibility
changed to assume modern C by default. See [FRQ 565088] for full
details.
2002-06-17 Don Porter <dgp@users.sourceforge.net>
* doc/msgcat.n: Corrected en_UK references to en_GB. UK is not a
country designation recognized in ISO 3166.
* library/msgcat/msgcat.tcl: More Windows Registry locale codes from
Bruno Haible.
* doc/msgcat.n:
* library/msgcat/msgcat.tcl:
* library/msgcat/pkgIndex.tcl:
* tests/msgcat.test: Revised locale initialization to interpret
environment variable locale values according to XPG4, and to recognize
the LC_ALL and LC_MESSAGES values over that of LANG. Also added many
Windows Registry locale values to those recognized by msgcat. Revised
tests and docs. Bumped to version 1.3. Thanks to Bruno Haible for the
report and assistance crafting the solution. [Bug 525522, 525525]
2002-06-16 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompile.c (TclCompileTokens): a better algorithm for the
previous bug fix.
2002-06-16 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompile.c (TclCompileTokens):
* tests/compile.test: [Bug 569438] in the processing of dollar
variables; report by Georgios Petasis.
2002-06-16 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: bug in the consolidation of the INCR_..._STK
instructions; the bug could not be exercised as the (faulty)
instruction INST_INCR_ARRAY_STK was never compiled-in (related to [Bug
569438]).
2002-06-14 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c (TclExecuteByteCode): runtime peep-hole
optimisation of variables (INST_STORE, INST_INCR) and commands
(INST_INVOKE); faster check for the existence of a catch.
(TclExecuteByteCode): runtime peep-hole optimisation of comparisons.
(TclExecuteByteCode): runtime peep-hole optimisation of INST_FOREACH -
relies on peculiarities of the code produced by the bytecode compiler.
2002-06-14 David Gravereaux <davygrvy@pobox.com>
* win/rules.vc: The test for compiler optimizations was in error.
Thanks goes to Roy Terry <royterry@earthlink.net> for his assistance
with this.
2002-06-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/trace.n, tests/trace.test:
* generic/tclCmdMZ.c (Tcl_TraceObjCmd,TclTraceCommandObjCmd)
(TclTraceVariableObjCmd): Changed references to "trace list" to "trace
info" as mandated by TIP#102.
2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c (TclExecuteByteCode): consolidated code for the
conditional branch instructions.
2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c (TclExecuteByteCode): fixed the previous
patch - wouldn't compile with TCL_COMPILE_DEBUG set.
2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c (TclExecuteByteCode): consolidated the handling
of exception returns to INST_INVOKE and INST_EVAL, as well as most of
the code for INST_CONTINUE and INST_BREAK, in the new jump target
"processExceptionReturn".
2002-06-13 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c (TclExecuteByteCode): consolidated variable
handling opcodes, replaced redundant code with some 'goto'. All
store/append/lappend opcodes on the same data type now share the main
code; same with incr opcodes.
* generic/tclVar.c: added the bit TCL_TRACE_READS to the possible
flags to Tcl_SetVar2Ex - it causes read traces to be fired prior to
setting the variable. This is used in the core for [lappend].
***NOTE*** the usage of TCL_TRACE_READS in Tcl_(Obj)?GetVar.* is not
documented; there, it causes the call to create the variable if it
does not exist. The new usage in Tcl_(Obj)?SetVar.* remains
undocumented too ...
2002-06-13 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/fCmd.test:
* tests/winFile.test:
* tests/fileSystem.test:
* generic/tclTest.c:
* generic/tclCmdAH.c:
* generic/tclIOUtil.c:
* doc/FileSystem.3:
* mac/tclMacFile.c:
* unix/tclUnixFile.c:
* win/tclWinFile.c: fixed up further so both compiles and actually
works with VC++ 5 or 6.
* win/tclWinInt.h:
* win/tclWin32Dll.c: cleaned up code and vfs tests and added tests for
the internal changes of 2002-06-12, to see whether WinTcl on NTFS can
coexist peacefully with links in the filesystem. Added new test
command 'testfilelink' to enable the newer code to be tested.
* tests/fCmd.test: (made certain tests of 'testfilelink' not run on
unix).
2002-06-12 Miguel Sofer <msofer@users.sourceforge.net>
* tclBasic.c (Tcl_DeleteTrace): fixed [Bug 568123] (thanks to
Hemang Lavana)
2002-06-12 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinFile.c: corrected the symbolic link handling code to
allow it to compile. Added real definition of REPARSE_DATA_BUFFER
(found in winnt.h). Most of the added definitions appear to have
correct, cross-Win-version equivalents in winnt.h and should be
removed, but just making things "work" for now.
2002-06-12 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c:
* generic/tcl.decls:
* generic/tclDecls.h: made code for Tcl_FSNewNativePath agree with man
pages.
* doc/FileSystem.3: clarified the circumstances under which certain
functions are called in the presence of symlinks.
* win/tclWinFile.c:
* win/tclWinPort.h:
* win/tclWinInt.h:
* win/tclWinFCmd.c: Fix for Windows to allow 'file lstat', 'file
type', 'glob -type l', 'file copy', 'file delete', 'file normalize',
and all VFS code to work correctly in the presence of symlinks
(previously Tcl's behaviour was not very well defined). This also
fixes possible serious problems in all versions of WinTcl where 'file
delete' on a NTFS symlink could delete the original, not the symlink.
Note: symlinks cannot yet be created in pure Tcl.
2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c:
* generic/tclCompCmds.c:
* generic/tclInt.h: reverted the new compilation functions; replaced
by a more general approach described below.
* generic/tclCompCmds.c:
* generic/tclCompile.c: made *all* compiled variable access attempts
create an indexed variable - even get or incr without previous set.
This allows indexed access to local variables that are created and set
at runtime, for example by [global], [upvar], [variable], [regexp],
[regsub].
2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
* doc/global.n:
* doc/info.n:
* test/info.test:
* generic/tclCmdIL.c: fix for [Bug 567386], [info locals] was
reporting some linked variables.
* generic/tclBasic.c:
* generic/tclCompCmds.c:
* generic/tclInt.h: added compile functions for [global], [variable]
and [upvar]. They just declare the new local variables, the commands
themselves are not compiled-in. This gives a notably faster read
access to these linked variables.
2002-06-11 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: optimised algorithm for exception range
lookup; part of [Patch 453709].
2002-06-10 Vince Darley <vincentdarley@users.sourceforge.net>
* unix/tclUnixFCmd.c: fixed [Bug 566669]
* generic/tclIOUtil.c: improved and sped up handling of native paths
(duplication and conversion to normalized paths), particularly on
Windows.
* modified part of above commit, due to problems on Linux. Will
re-examine bug report and evaluate more closely.
2002-06-07 Don Porter <dgp@users.sourceforge.net>
* tests/tcltest.test: More corrections to test suite so that tests of
failing [test]s don't show up themselves as failing tests.
2002-06-07 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclExecute.c: Tidied up headers in relation to float.h to
cut the cruft and ensure DBL_MAX is defined since doubles seem to be
the same size everywhere; if the assumption isn't true, the variant
platforms had better have run configure...
* unix/tclUnixPort.h (EOVERFLOW): Added code to define it if it wasn't
previously defined. Also some other general tidying and adding of
comments. [Bugs 563122, 564595]
* compat/tclErrno.h: Added definition for EOVERFLOW copied from
Solaris headers; I've been unable to find any uses of EFTYPE, which
was the error code previously occupying the slot, in Tcl, or any
definition of it in the Solaris headers.
2002-06-06 Mo DeJong <mdejong@users.sourceforge.net>
* unix/dltest/Makefile.in: Remove hard coded CFLAGS=-g and add
CFLAGS_DEBUG, CFLAGS_OPTIMIZE, and CFLAGS_DEFAULT varaibles. [Bug
565488]
2002-06-06 Don Porter <dgp@users.sourceforge.net>
* tests/tcltest.test: Corrections to test suite so that tests of
failing [test]s don't show up themselves as failing tests.
* tests/io.test: Fixed up namespace variable resolution issues
revealed by running test suite with "-singleproc 1".
* doc/tcltest.n:
* library/tcltest/tcltest.tcl:
* tests/tcltest.test: Several updates to tcltest.
1) changed to lazy initialization of test constraints
2) deprecated [initConstraintsHook]
3) repaired badly broken [limitConstraints].
4) deprecated [threadReap] and [mainThread]
[Patch 512214, Bug 558742, Bug 461000, Bug 534903]
2002-06-06 Daniel Steffen <das@users.sourceforge.net>
* unix/tclUnixThrd.c (TclpReaddir, TclpLocaltime, TclpGmtime):
added mutex wrapped calls to readdir, localtime & gmtime in case their
thread-safe *_r counterparts are not available.
* unix/tcl.m4: added configure check for readdir_r
* unix/tcl.m4 (Darwin): set TCL_DEFAULT_ENCODING to utf-8 on MacOSX
(where posix file apis expect utf-8, not iso8859-1).
* unix/configure: regen
* unix/Makefile.in: set DYLD_LIBRARY_PATH in parallel to
LD_LIBRARY_PATH for MacOSX dynamic linker.
* generic/tclEnv.c (TclSetEnv): fix env var setting on MacOSX. Adapted
from [Patch 524352] (jkbonfield).
2002-06-05 Don Porter <dgp@users.sourceforge.net>
* doc/Tcl_Main.3: Documented $tcl_rcFileName and added more
clarifications about the intended use of Tcl_Main(). [Bug 505651]
2002-06-05 Daniel Steffen <das@users.sourceforge.net>
* generic/tclFileName.c (TclGlob): mac specific fix to recent changes
in 'glob -tails' handling.
* mac/tclMacPort.h:
* mac/tclMacChan.c: fixed TIP#91 bustage.
* mac/tclMacResource.c (Tcl_MacConvertTextResource): added utf
conversion of text resource contents.
* tests/macFCmd.test (macFCmd-1.2): allow CWIE creator.
2002-06-04 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl:
* tests/init.test:
* tests/tcltest.test: Added more TIP 85 tests from Arjen Markus.
Converted tcltest.test to use a private namespace. Fixed bugs in
[tcltest::Eval] revealed by calling [tcltest::test] from a non-global
namespace, and namespace errors in init.test.
2002-06-04 Mo DeJong <mdejong@users.sourceforge.net>
* win/README: Update msys+mingw URL.
2002-06-03 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n:
* library/tcltest/tcltest.tcl:
* library/tcltest/pkgIndex.tcl:
* tests/tcltest.test: Implementation of TIP 85. Allows tcltest users
to add new legal values of the -match option to [test], associating
each with a Tcl command that does the matching of expected results
with actual results of tests. Thanks to Arjen Markus. => tcltest 2.1
[Patch 521362]
2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
* doc/namespace.n: added description of [namepace forget] behaviour
for unqualified patterns [Bug 559268]
2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: reverting an accidental modification in the
last commit.
2002-06-03 Miguel Sofer <msofer@users.sourceforge.net>
* doc/Tcl.n: clarify the empty variable name issue ([Bug 549285]
reported by Tom Krehbiel, patch by Don Porter).
2002-05-31 Don Porter <dgp@users.sourceforge.net>
* library/package.tcl: Fixed leak of slave interp in [pkg_mkIndex].
Thanks to Helmut for report. [Bug 550534]
* tests/io.test:
* tests/main.test: Use the "stdio" constraint to control whether an
[open "|[interpreter]"] is attempted.
* generic/tclExecute.c (TclMathInProgress,TclExecuteByteCode
(ExprCallMathFunc):
* generic/tclInt.h (TclMathInProgress):
* unix/Makefile.in (tclMtherr.*):
* unix/configure.in (NEED_MATHERR):
* unix/tclAppInit.c (matherr):
* unix/tclMtherr.c (removed file):
* win/tclWinMtherr.c (_matherr): Removed internal routine
TclMathInProgress and Unix implementation of matherr(). These are now
obsolete, dealing with very old versions of the C math library.
Windows version is retained in case Borland compilers require it, but
it is inactive. Thanks to Joe English. [Bug 474335, Patch 555635]
* unix/configure: regen
2002-05-30 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompExpr.c:
* generic/tclCompile.c:
* generic/tclCompile.h: removed exprIsJustVarRef and
exprIsComparison from the ExprInfo and CompileEnv structs. These were
set, but not used since dec 1999 [Bug 562383].
2002-05-30 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFileName.c (TclGlob): fix to longstanding 'knownBug' in
fileName tests 15.2-15.4, and fix to a new Tcl 8.4 bug in certain uses
of 'glob -tails'.
* tests/fileName.test: removed 'knownBug' flag from some tests, added
some new tests for above bugs.
2002-05-29 Jeff Hobbs <jeffh@ActiveState.com>
* unix/configure: regen'ed
* unix/configure.in: replaced bigendian check with autoconf standard
AC_C_BIG_ENDIAN, which defined WORDS_BIGENDIAN on bigendian systems.
* generic/tclUtf.c (Tcl_UniCharNcmp):
* generic/tclInt.h (TclUniCharNcmp): use WORDS_BIGENDIAN instead of
TCL_OPTIMIZE_UNICODE_COMPARE to enable memcmp alternative.
* generic/tclExecute.c (TclExecuteByteCode INST_STR_CMP):
* generic/tclCmdMZ.c (Tcl_StringObjCmd): changed the case for choosing
the Tcl_UniCharNcmp compare to when both objs are of StringType, as
benchmarks show that is the optimal check (both bigendian and
littleendian systems).
2002-05-29 Don Porter <dgp@users.sourceforge.net>
* generic/tclMain.c: Removed "dummy" reference to Tcl_LinkVar. It is
no longer needed since Tcl_Main() now actually calls Tcl_LinkVar().
Thanks to Joe English for pointing that out.
2002-05-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclExecute.c (TclExecuteByteCode):
* generic/tclCmdMZ.c (Tcl_StringObjCmd): Use the macro version.
* generic/tclInt.h (TclUniCharNcmp): Optimised still further with a
macro for use in sensitive places like tclExecute.c
* generic/tclUtf.c (Tcl_UniCharNcmp): Use new flag to figure out when
we can use an optimal comparison scheme, and default to the old scheme
in other cases which is at least safe.
* unix/configure.in (TCL_OPTIMIZE_UNICODE_COMPARE): New optional flag
that indicates when we can use memcmp() to compare Unicode strings
(i.e. when the high-byte of a Tcl_UniChar precedes the low-byte.)
2002-05-29 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclInt.decls:
* generic/tclIntDecls.h:
* generic/tclStubInit.c:
* generic/tclUtf.c: added TclpUtfNcmp2 private command that mirrors
Tcl_UtfNcmp, but takes n in bytes, not utf-8 chars. This provides a
faster alternative for comparing utf strings internally.
(Tcl_UniCharNcmp, Tcl_UniCharNcasecmp): removed the explicit end of
string check as it wasn't correct for the function (by doc and logic).
* generic/tclCmdMZ.c (Tcl_StringObjCmd): reworked the string equal
comparison code to use TclpUtfNcmp2 as well as short-circuit for equal
objects or unequal length strings in the equal case. Removed the use
of goto and streamlined the other parts.
* generic/tclExecute.c (TclExecuteByteCode): added check for object
equality in the comparison instructions. Added short-circuit for !=
length strings in INST_EQ, INST_NEQ and INST_STR_CMP. Reworked
INST_STR_CMP to use TclpUtfNcmp2 where appropriate, and only use
Tcl_UniCharNcmp when at least one of the objects is a Unicode obj with
no utf bytes.
* generic/tclCompCmds.c (TclCompileStringCmd): removed error creation
in code that no longer throws an error.
* tests/string.test:
* tests/stringComp.test: added more string comparison checks.
* tests/clock.test: better qualified 9.1 constraint check for %s.
2002-05-28 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclThreadAlloc.c (TclpRealloc, TclpFree): protect against
the case when NULL is based.
* tests/clock.test: added clock-9.1
* compat/strftime.c:
* generic/tclClock.c:
* generic/tclInt.decls:
* generic/tclIntDecls.h:
* unix/tclUnixTime.c: fix for Windows msvcrt mem leak caused by using
an env(TZ) setting trick for in clock format -gmt 1. This also makes
%s seem to work correctly with -gmt 1 as well as making it a lot
faster by avoid the env(TZ) hack. TclpStrftime now takes useGMT as an
arg. [Bug 559376]
2002-05-28 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c: fixes to Tcl_FSLoadFile when called on a file
inside a vfs. This should avoid leaving temporary files sitting around
on exit. [Bug 545579]
2002-05-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* win/tclWinError.c: Added comment on conversion of
ERROR_NEGATIVE_SEEK because that is a mapping that really belongs, and
not a catch-all case.
* win/tclWinPort.h (EOVERFLOW): Should be either EFBIG or EINVAL
* generic/tclPosixStr.c (Tcl_ErrnoId, Tcl_ErrnoMsg): EOVERFLOW can
potentially be a synonym for EINVAL.
2002-05-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
=== Changes due to TIP#91 ===
* win/tclWinPort.h: Added declaration of EOVERFLOW.
* doc/CrtChannel.3: Added documentation of wideSeekProc.
* generic/tclIOGT.c (TransformSeekProc, TransformWideSeekProc):
Adapted to use the new channel mechanism.
* unix/tclUnixChan.c (FileSeekProc, FileWideSeekProc): Renamed
FileSeekProc to FileWideSeekProc and created new FileSeekProc which
has the old-style interface and which errors out with EOVERFLOW when
the returned file position can't fit into the return type (int for
historical reasons.)
* win/tclWinChan.c (FileSeekProc, FileWideSeekProc): Renamed
FileSeekProc to FileWideSeekProc and created new FileSeekProc which
has the old-style interface and which errors out with EOVERFLOW when
the returned file position can't fit into the return type (int for
historical reasons.)
* mac/tclMacChan.c (FileSeek): Reverted to old interface; Macs lack
large-file support because I can't see how to add it.
* generic/tclIO.c (Tcl_Seek, Tcl_Tell): Given these functions
knowledge of the new arrangement of channel types.
(Tcl_ChannelVersion): Added recognition of new version code.
(HaveVersion): New function to do version checking.
(Tcl_ChannelBlockModeProc, Tcl_ChannelFlushProc)
(Tcl_ChannelHandlerProc): Made these functions use HaveVersion for
ease of future maintainability.
(Tcl_ChannelBlockModeProc): Obvious lookup function.
* generic/tcl.h (Tcl_ChannelType): New wideSeekProc field, and
seekProc type restored to old interpretation.
(TCL_CHANNEL_VERSION_3): New channel version.
2002-05-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* tests/winPipe.test: Applied patch for [Bug 549617]. Patch and bug
report by Kevin Kenny <kennykb@users.sourceforge.net>.
* win/tclWinSock.c (TcpWatchProc): Fixed [Bug 557878]. We are not
allowed to mess with the watch mask if the socket is a server socket.
I believe that the original reporter is George Peter Staplin.
2002-05-21 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/configure.in: Invoke SC_ENABLE_SHARED before calling
SC_CONFIG_CFLAGS so that the SHARED_BUILD variable can be checked
inside SC_CONFIG_CFLAGS.
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Pass -non_shared instead of -shared
to ld when configured with --disable-shared under OSF. [Bug 540390]
2002-05-20 Daniel Steffen <das@users.sourceforge.net>
* generic/tclInt.h: added prototype for TclpFilesystemPathType().
* mac/tclMacChan.c: use MSL provided creator type if available instead
of the default 'MPW '.
2002-05-16 Joe English <jenglish@users.sf.net>
* doc/CrtObjCmd.3: Added Tcl_GetCommandFromObj, Tcl_GetCommandFullName
[Bugs 547987, 414921]
2002-05-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* unix/tclUnixChan.c (TtyOutputProc): #if/#endif-ed this function out
to stop compiler warnings. Also much general tidying of comments in
this file and removal of whitespace from blank lines.
2002-05-13 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* unix/tclUnixChan.c (SETBREAK): Solaris thinks ioctl() takes a signed
second argument, and Linux thinks ioctl() takes an unsigned second
argument. So need a longer definition of this macro to get neither to
spew warnings...
2002-05-13 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclEvent.c:
* generic/tclIOUtil.c:
* generic/tclInt.h: clean up all memory allocated by the filesystem,
via introduction of 'TclFinalizeFilesystem'. Move TclFinalizeLoad into
TclFinalizeFilesystem so we can be sure it is called at just the right
time. Fix bad comment also. [Bug 555078 and 'fs' part of 543549]
* win/tclWinChan.c: fix comment referring to wrong function.
2002-05-10 Don Porter <dgp@users.sourceforge.net>
* tests/load.test:
* tests/safe.test:
* tests/tcltest.test: Corrected some list-quoting issues and other
matters that cause tests to fail when the patch includes special
characters. Report from Vince Darley. [Bug 554068].
2002-05-08 David Gravereaux <davygrvy@pobox.com>
* doc/file.n:
* tools/man2tcl.c:
* tools/man2help2.tcl: Thanks to Peter Spjuth <peter.spjuth@space.se>,
again. My prior fix for single-quote macro mis-understanding was
wrong. Reverted to reimpliment the 'macro2' proc which handles
single-quote macros and restored file.n text arrangement to avoid
single-quotes on the first line. Sorry for all the confusion.
2002-05-08 David Gravereaux <davygrvy@pobox.com>
* tools/man2tcl.c:
* tools/man2help2.tcl: Proper source of macro error mis-understanding
single-quote as the leading macro command found and repaired.
* doc/file.n: Reverted to prior state before I messed with it.
2002-05-08 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Corrected [uplevel] quoting when
[source]-ing test script in subdirectories.
* tests/fileName.test:
* tests/load.test:
* tests/main.test:
* tests/tcltest.test:
* tests/unixInit.test: Fixes to test suite when there's a space in the
working path. Thanks to Kevin Kenny.
2002-05-07 David Gravereaux <davygrvy@pobox.com>
-- Changes from Peter Spjuth <peter.spjuth@space.se>
* tools/man2tcl.c: Increased line buffer size and a bail-out if that
should ever be over-run.
* tools/man2help.tcl: Include Courier New font in rtf header.
* tools/man2help2.tcl: Improved handling of CS/CE fields. Use Courier
New for code samples and indent better.
* doc/file.n:
* doc/TraceCmd.3: winhelp conversion tools where understanding a ' as
the first character on a line to be an unknown macro. Not knowing how
to repair tools/man2tcl.c, I decided to rearrange the text in the docs
instead.
2002-05-07 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFileName.c: fix to similar segfault when using
'glob -types nonsense -dir dirname -join * *'. [Bug 553320]
* doc/FileSystem.3: further documentation on vfs.
* tests/cmdAH.test:
* tests/fileSystem.test:
* tests/pkgMkindex.test: Fix to testsuite bugs when running out of
directory whose name contains '{' or '['.
2002-05-07 Miguel Sofer <msofer@users.sourceforge.net>
* tests/basic.test: Fix for [Bug 549607]
* tests/encoding.test: Fix for [Bug 549610]
These are testsuite bugs that caused failures when the filename
contained spaces. Report & fix by Kevin Kenny.
2002-05-02 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFileName.c: fix to freeing a bad object (i.e. segfault)
when using 'glob -types nonsense -dir dirname'.
* generic/tclWinFile.c: fix to [Bug 551306], also wrapped some long
lines.
* tests/fileName.test: added several tests for the above bugs.
* doc/FileSystem.3: clarified documentation on refCount requirements
of the object returned by the path type function.
* generic/tclIOUtil.c:
* win/tclWinFile.c:
* unix/tclUnixFile.c:
* mac/tclMacFile.c: moved TclpFilesystemPathType to the platform
specific directories, so we can add missing platform-specific
implementations. On Windows, 'file system' now returns useful results
like "native NTFS", "native FAT" for that system. Unix and MacOS still
only return "native".
* doc/file.n: clarified documentation.
* tests/winFile.test: test for 'file system' returning correct values.
* tests/fileSystem.test: test for 'file system' returning correct
values. Clean up after failed previous test run.
2002-04-26 Jeff Hobbs <jeffh@ActiveState.com>
* unix/configure:
* unix/tcl.m4: change HP-11 SHLIB_LD_LIBS from "" to ${LIBS} so that
the .sl knows its dependent libs.
2002-04-26 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/obj.test (obj-11.[56]): Test conversion to boolean more
thoroughly.
* generic/tclObj.c (SetBooleanFromAny): Was not calling an integer
parsing function on native 64-bit platforms! [Bug 548686]
2002-04-24 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclInt.h: corrected TclRememberJoinableThread decl to use
VOID instead of void.
* generic/tclThreadJoin.c: noted that this code isn't needed on Unix.
2002-04-23 Jeff Hobbs <jeffh@ActiveState.com>
* doc/exec.n:
* doc/tclvars.n: doc updates [Patch 509426] (gravereaux)
2002-04-24 Daniel Steffen <das@users.sourceforge.net>
* mac/tclMacResource.r: added check of TCLTK_NO_LIBRARY_TEXT_RESOURCES
#define to allow disabling the inclusion of the tcl library code in
the resource fork of Tcl executables and shared libraries.
2002-04-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/TraceCmd.3: New file that documents Tcl_CommandTraceInfo,
Tcl_TraceCommand and Tcl_UntraceCommand [Bug 414927]
2002-04-22 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclAlloc.c:
* generic/tclInt.h:
* generic/tclThreadAlloc.c (new):
* unix/Makefile.in:
* unix/tclUnixThrd.c:
* win/Makefile.in:
* win/tclWinInt.h:
* win/tclWinThrd.c: added new threaded allocator contributed by AOL
that significantly reduces lock contention when multiple threads are
in use. Only Windows and Unix implementations are ready, and the
Windows one may need work. It is only used by default on Unix for now,
and requires that USE_THREAD_ALLOC be defined (--enable-threads on
Unix will define this).
* generic/tclIOUtil.c (Tcl_FSRegister, Tcl_FSUnregister): corrected
calling of Tcl_ConditionWait to ensure that there would be a condition
to wait upon.
* generic/tclCmdAH.c (Tcl_FileObjCmd): added cast in FILE_SIZE.
* win/tclWinFCmd.c (DoDeleteFile): check return of setattr API calls
in file deletion for correct Win32 API handling.
* win/Makefile.in: correct dependencies for shell, gdb, runtest
targets.
* doc/clock.n:
* compat/strftime.c (_fmt): change strftime to correctly handle
localized %c, %x and %X on Windows. Added some notes about how the
other values could be further localized.
2002-04-19 Don Porter <dgp@users.sourceforge.net>
* generic/tclMain.c (Tcl_Main): Free the memory allocated for the
startup script path. [Bug 543549]
* library/msgcat/msgcat.tcl: [mcmax] wasn't using the caller's
namespace when determining the max translated length. Also made
revisions for better use of namespace variables and more efficient
[uplevel]s.
* doc/msgcat.n:
* library/msgcat/msgcat.tcl:
* library/msgcat/pkgIndex.tcl: Added [mcload] to the export list of
msgcat; bumped to 1.2.3. [Bug 544727]
2002-04-20 Daniel Steffen <das@users.sourceforge.net>
* generic/tclInt.decls:
* generic/tclIntPlatDecls.h:
* generic/tclStubInit.c:
* mac/tclMacFCmd.c:
* mac/tclMacFile.c:
* mac/tclMacUtil.c: Modified TclpObjNormalizePath to be alias file
aware, and replaced various calls to FSpLocationFrom*Path by calls to
new alias file aware versions FSpLLocationFrom*Path. The alias file
aware routines don't resolve the last component of a path if it is an
alias. This allows [file copy/delete] etc. to act correctly on alias
files. (c.f. discussion in [Bug 511666])
2002-04-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/lindex.test (lindex-3.7):
* generic/tclUtil.c (TclGetIntForIndex): Stopped indexes from hitting
wide ints. [Bug 526717]
2002-04-18 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclNamesp.c:
* tests/info.test: [Bug 545325] info level didn't report namespace
eval, bug report by Richard Suchenwirth.
2002-04-18 Don Porter <dgp@users.sourceforge.net>
* doc/subst.n: Clarified documentation on handling unusual return
codes during substitution, and on variable substitutions implied by
command substitution, and vice versa. [Bug 536838]
2002-04-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdIL.c (InfoBodyCmd):
* tests/info.test (info-2.6): Proc bodies without string reps would
report as empty [Bug 545644]
* generic/tclCmdMZ.c (Tcl_SubstObj): More clarification for comment on
behaviour when substitutions are not well-formed, prompted by [Bug
536831]; alas, removing the ill-defined behaviour is a lot of work.
2002-04-18 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c:
* tests/expr-old.test: fix for [Bug 542588] (Phil Ehrens), where "too
large integers" were reported as "floating-point value" in [expr]
error messages.
2002-04-17 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclEncoding.c (EscapeFromUtfProc):
* generic/tclIO.c (WriteChars, Tcl_Close): corrected the handling of
outputting end escapes for escape-based encodings.
[Bug 526524] (yamamoto)
2002-04-17 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n: Removed [saveState] and [restoreState] from tcltest
2 documentation, effectively deprecating them. [Bug 495660]
* library/tcltest/tcltest.tcl: Made separate export for commands kept
only for tcltest 1 compatibility.
* tests/iogt.test: Revised to run tests in a namespace, rather than
use the useless and buggy [saveState] and [restoreState] commands of
tcltest. Updated to use tcltest 2 as well. [Patch 544911]
2002-04-16 Don Porter <dgp@users.sourceforge.net>
* tests/io.test: Revised to run tests in a namespace, rather than use
the useless and buggy [saveState] and [restoreState] commands of
tcltest. Updated to use tcltest 2 as well. [Patch 544546]
2002-04-15 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclProc.c:
* tests/proc-old.test: Improved stack trace for TCL_BREAK and
TCL_CONTINUE returns from procs. [Bug 536955] (dgp)
* generic/tclExecute.c:
* tests/compile.test: made bytecodes check for a catch before
returning; the compiled [return] is otherwise non-catchable. [Bug
542142] reported by Andreas Kupries.
2002-04-15 Don Porter <dgp@users.sourceforge.net>
* tests/socket.test: Increased timeout values so that tests have time
to successfully complete even on slow/busy machines. [Bug 523470]
* doc/tcltest.n:
* library/tcltest/tcltest.tcl:
* tests/tcltest.test: Revised [tcltest::test] to return errors when
called with invalid syntax and to accept exactly two arguments as
documented. Improved error messages. [Bug 497446, Patch 513983]
***POTENTIAL INCOMPATIBILITY***: Incompatible with previous
tcltest 2.* releases, found only in alpha releases of Tcl 8.4.
2002-04-11 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclNotify.c (TclFinalizeNotifier): remove remaining
unserviced events on finalization.
* win/tcl.m4: Enabled COFF as well as CV style debug info with
--enable-symbols to allow Dr. Watson users to see function info. More
info on debugging levels can be obtained at:
http://msdn.microsoft.com/library/en-us/dnvc60/html/gendepdebug.asp
* tests/ioCmd.test: fixed iocmd-8.15 to have mac and unixPc variants.
* generic/tclParse.c (Tcl_ParseVar): conditionally incr obj refcount
to prevent possible mem leak.
2002-04-08 Daniel Steffen <das@users.sourceforge.net>
* generic/tcl.h: no <sys/types.h> on mac.
* mac/tclMacFile.c: minor fixes to Vince's changes from 03-24.
* mac/tclMacOSA.c:
* mac/tclMacResource.c: added missing Tcl_UtfToExternalDString
conversions of resource file names.
* mac/tclMacSock.c (TcpGetOptionProc): fixed bug introduced by Andreas
on 02-25; changed strcmp's to strncmp's so that option comparison
behaves like on other platforms.
* mac/tcltkMacBuildSupport.sea.hqx (CW Pro6 changes): added support to
allow Tk to hookup C library stderr/stdout to TkConsole.
* tests/basic.test:
* tests/cmdAH.test:
* tests/encoding.test:
* tests/fileSystem.test:
* tests/ioCmd.test: fixed tests failing on mac: check for existence of
[exec], changed some result strings.
2002-04-06 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixFCmd.c (Realpath): added a little extra code to
initialize a realpath arg when compiling in PURIFY mode in order to
prevent spurious purify warnings. We should really create our own
realpath implementation, but this will at least quiet purify for now.
2002-04-05 Don Porter <dgp@users.sourceforge.net>
* generic/tclCmdMZ.c (Tcl_SubstObj):
* tests/subst.test: Corrected [subst] so that return codes TCL_BREAK
and TCL_CONTINUE returned by variable substitution have the same
effect as when those codes are returned by command substitution. [Bug
536879]
2002-04-03 Jeff Hobbs <jeffh@ActiveState.com>
* library/tcltest/tcltest.tcl: added getMatchingFiles back (alias
to GetMatchingFiles), which was a public function in tcltest 1.0.
2002-04-01 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclEnv.c:
* generic/tclIOUtil.c: invalidate filesystem cache when the user
changes env(HOME). Fixes [Bug 535621]. Also cleaned up some of the
documentation.
* tests/fileSystem.test: added test for bug just fixed.
2002-04-01 Kevin Kenny <kennykb@acm.org>
* win/tclWinTime.c (Tcl_GetTime): made the checks of clock frequency
more permissive to cope with the fact that Win98SE is observed to
return 1.19318 in place of 1.193182 for the performance counter
frequency.
2002-03-29 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclCmdMZ.c (Tcl_TraceObjCmd, TraceVarProc)
(TraceCommandProc, TclTraceCommandObjCmd): corrected potential
double-free of traces on variables by flagging in Trace*Proc that it
will free the var in case the eval wants to delete the var trace as
well. [Bug 536937]
Also converted Tcl_UntraceVar -> Tcl_UntraceVar2 and Tcl_Eval to
Tcl_EvalEx in Trace*Proc for slight efficiency improvement.
2002-03-29 Don Porter <dgp@users.sourceforge.net>
* doc/AllowExc.3:
* generic/tclBasic.c (Tcl_EvalObjv,Tcl_EvalEx,Tcl_EvalObjEx):
* generic/tclCompile.h (TclCompEvalObj):
* generic/tclExecute.c (TclCompEvalObj,TclExecuteByteCode):
* tests/basic.test: Corrected problems with Tcl_AllowExceptions having
influence over the wrong scope of Tcl_*Eval* calls. Patch from Miguel
Sofer. Report from Jean-Claude Wippler. [Bug 219181]
2002-03-28 Don Porter <dgp@users.sourceforge.net>
* generic/tclVar.c: Refactored CallTraces to collect repeated handling
of its returned value into CallTraces itself.
2002-03-28 David Gravereaux <davygrvy@pobox.com>
* tools/feather.bmp:
* tools/man2help.tcl:
* tools/man2help2.tcl:
* win/makefile.vc: More winhelp target fixups. Added a feather bitmap
to the non-scrollable area and changed the color to be yellow from a
plain white. The colors can be whatever we want them to be, but
thought I would start with something bold. [Bug 527941]
* doc/SetVar.3:
* doc/TraceVar.3:
* doc/UpVar.3: .AP macro syntax repair.
2002-03-27 David Gravereaux <davygrvy@pobox.com>
* tools/man2help.tcl:
* win/makefile.vc: winhelp target now copies all needed files from
tools/ to a workarea under $(OUT_DIR) and builds it from there. No
build cruft is left in tools/ anymore. All paths used in man2help.tcl
are now relative to where the script is. [Bug 527941]
2002-03-27 David Gravereaux <davygrvy@pobox.com>
* win/.cvsignore:
* win/buildall.vc.bat:
* win/coffbase.txt:
* win/makefile.vc:
* win/nmakehlp.c (new):
* win/rules.vc: First draft fix for [Bug 527941]. More changes need to
done to the makehelp target to get to stop leaving build files in the
tools/ directory. This does not address the syntax errors in the man
files. Having the contents of tcl.hpj(.in) inside makefile.vc allows
for version numbers to be replaced with macros.
The new nmakehlp.c is built by rules.vc in preprocessing and removes
the need to use tricky shell syntax that wasn't compatible on Win9x
systems. Clean targets made Win9x complient. This is a first draft
repair for [Bug 533862].
2002-03-28 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c (Tcl_EvalEx): passing the correct commandSize
to TclEvalObjvInternal. [Bug 219362], fix by David Knoll.
2002-03-28 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c (Tcl_EvalEx):
* tests/basic.test: avoid exceptional returns at level 0
[Bug 219181]
2002-03-27 Don Porter <dgp@users.sourceforge.net>
* doc/tcltest.n ([mainThread]):
* library/tcltest/tcltest.tcl:
* tests/tcltest.test: Major code cleanup to deal with whitespace,
coding conventions, and namespace issues, with several minor bugs
fixed in the process.
* tests/main.test: Added missing [after cancel]s.
2002-03-25 Don Porter <dgp@users.sourceforge.net>
* tests/main.test: Removed workarounds for Bug 495977.
* library/tcltest/tcltest.tcl: Keep the value of $::auto_path
unchanged, so that the tcltest package can test code that depends
on auto-loading. If a testing application needs $::auto_path pruned,
it should do that itself. [Bug 495726]
Improve the processing of the -constraints option to [test] so that
constraint lists can have arbitrary whitespace, and non-lists don't
blow things up. [Bug 495977]
Corrected faulty variable initialization. [Bug 534845]
2002-03-25 Miguel Sofer <msofer@users.sourceforge.net>
* doc/CrtTrace.3: small doc correction
* generic/tclBasic.c (Tcl_DeleteTrace): Allow NULL callback on
trace deletions [Bug 534728] (Hemang Lavana).
2002-03-24 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c (Tcl_EvalObjv): replaced obscure, incorrect
code as described in [Bug 533907] (Don Porter).
2002-03-24 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl: Use [interpreter] to set/query the
executable currently running the tcltest package. [Bug 454050]
* library/tcltest/tcltest.tcl: Allow non-proc commands to be used
as the customization hooks. [Bug 495662]
2002-03-24 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFilename.c:
* generic/tclFCmd.c:
* generic/tclTest.c:
* generic/tcl.h:
* generic/tclIOUtil.c:
* win/tclWinFile.c:
* win/tclWinFCmd.c:
* win/tclWinPipe.c:
* unix/tclUnixFile.c:
* unix/tclUnixFCmd.c:
* mac/tclMacFile.c:
* doc/FileSystem.3:
* doc/file.n:
* tests/cmdAH.test:
* tests/fileName.test:
* tests/fileSystem.test: (new file)
* tests/winFCmd.test: fix [Bug 511666] and [Bug 511658], and improved
documentation of some aspects of the filesystem, particularly
'Tcl_FSMatchInDirectory' which now might match a single file/directory
only, and 'file normalize' which wasn't very clear before. Removed
inconsistency betweens docs and the Tcl_Filesystem structure. Also
fixed [Bug 523217] and corrected file normalization on Unix so that it
expands symbolic links. Added some new tests of the filesystem code
(in the new file 'fileSystem.test'), and some extra tests for correct
handling of symbolic links. Fix to [Bug 530960] which shows up on
Win98. Made comparison with ".com" case insensitive in tclWinPipe.c
***POTENTIAL INCOMPATIBILITY***: But only between alpha releases
(users of the new Tcl_Filesystem lookup table in Tcl 8.4a4 need to
handle the new way in which Tcl may call Tcl_FSMatchInDirectory, and
'file normalize' on unix now behaves correctly). Only known impact is
with the 'tclvfs' extension.
2002-03-22 Miguel Sofer <msofer@users.sourceforge.net>
* tests/basic.test (basic-46.1): adding test for [Bug 533758], fixed
earlier today.
2002-03-22 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinInt.h: moved undef of TCL_STORAGE_CLASS. [Bug 478579]
2002-03-22 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c (Tcl_EvalObjEx):
* generic/tclExecute.c (TclCompEvalObj): fixed the errorInfo for
return codes other than (TCL_OK, TCL_ERROR) to runLevel 0 [Bug
533758]. Removed the static RecordTracebackInfo(), as its
functionality is easily replicated by Tcl_LogCommandInfo. Bug and
redundancy noted by Don Porter.
2002-03-21 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/expr.n: Improved documentation for ceil and floor [Bug 530535]
2002-03-20 Don Porter <dgp@users.sourceforge.net>
* doc/SetVar.3:
* doc/TraceVar.3:
* doc/UpVar.3:
* generic/tcl.h (Tcl_VarTraceProc):
* generic/tcl.decls (Tcl_GetVar2, Tcl_SetVar2, Tcl_TraceVar2)
(Tcl_UnsetVar2, Tcl_UntraceVar2, Tcl_UpVar2, Tcl_VarTraceInfo2)
(Tcl_GetVar2Ex, TclSetVar2Ex):
* generic/tclCmdMZ.c (TraceVarProc):
* generic/tclEnv.c (EnvTraceProc):
* generic/tclEvent.c (VwaitVarProc):
* generic/tclInt.decls (TclLookupVar,TclPrecTraceProc):
* generic/tclLink.c (LinkTraceProc):
* generic/tclUtil.c (TclPrecTraceProc):
* generic/tclVar.c (CallTraces, MakeUpvar, VarErrMsg, TclLookupVar,
(Tcl_GetVar2, Tcl_SetVar2, Tcl_TraceVar2, Tcl_UnsetVar2)
(Tcl_UntraceVar2, Tcl_UpVar2, Tcl_VarTraceInfo2, Tcl_GetVar2Ex)
(TclSetVar2Ex): Updated interfaces of generic/tclVar.c according to
TIP 27. In particular, the "part2" arguments were CONSTified.
[Patch 532642]
* generic/tclDecls.h:
* generic/tclIntDecls.h: make genstubs
2002-03-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/compile.test (compile-12.3): Test to detect bug 530320.
* generic/tclCompile.c (TclCompileTokens): Fixed buffer overrun
reported in bug 530320.
2002-03-14 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure: Regen.
* win/configure.in: Add configure time test for SEH support in the
compiler.
* win/tclWin32Dll.c (ESP, EBP, TclpCheckStackSpace,
(_except_checkstackspace_handler):
* win/tclWinChan.c (ESP, EBP, Tcl_MakeFileChannel,
(_except_makefilechannel_handler):
* win/tclWinFCmd.c (ESP, EBP, DoRenameFile, DoCopyFile,
(_except_dorenamefile_handler, _except_docopyfile_handler): Implement
SEH support under gcc using inline asm. Tcl and Tk should now compile
with Mingw 1.1. [Patch 525746]
2002-03-14 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWinFCmd.c (DoRenameFile, DoCopyFile): Handle an SEH exception
with EXCEPTION_EXECUTE_HANDLER instead of restarting the faulting
instruction with EXCEPTION_CONTINUE_EXECUTION. Bug 466102 provides an
example of how restarting could send Tcl into an infinite loop. [Patch
525746]
2002-03-11 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWinFCmd.c (DoRenameFile, DoCopyFile, DoDeleteFile,
(DoRemoveJustDirectory): Make sure we don't pass NULL or "" as a path
name to Win32 API functions since this was crashing under Windows 98.
2002-03-11 Don Porter <dgp@users.sourceforge.net>
* library/tcltest/tcltest.tcl:
* library/tcltest/pkgIndex.tcl: Bumped tcltest package to 2.0.2.
2002-03-11 Mo DeJong <mdejong@users.sourceforge.net>
* library/tcltest/tcltest.tcl (getMatchingFiles): Pass a proper list
to foreach to avoid munging a Windows patch like D:\Foo\Bar into
D:FooBar before the glob.
2002-03-11 Mo DeJong <mdejong@users.sourceforge.net>
* generic/tclEncoding.c: Fix typo in comment.
* generic/tclIO.c (DoReadChars, ReadBytes, ReadChars): Use NULL value
instead of pointer set to NULL to make things more clear. Reorder
arguments so that they match the function signatures. Cleanup little
typos and add more descriptive comment.
2002-03-08 Mo DeJong <mdejong@users.sourceforge.net>
* win/README: Update to indicate that Mingw 1.1 is required to build
Tcl. Add section describing new msys based build process. Update
Cygwin build instructions so users know where to find Mingw 1.1.
2002-03-08 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinFCmd.c (DoCopyFile): correctly set retval to TCL_OK.
2002-03-07 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWin32Dll.c (TclpCheckStackSpace):
* win/tclWinFCmd.c (DoRenameFile, DoCopyFile): Replace hard coded
constants with Win32 symbolic names. Move control flow statements out
of __try blocks since the documentation indicates it is frowned upon.
2002-03-07 Don Porter <dgp@users.sourceforge.net>
* doc/interp.n:
* generic/tclInterp.c (Tcl_InterpObjCmd,SlaveObjCmd,
(SlaveRecursionLimit):
* generic/tclTest.c:
* tests/interp.test: Added the [interp recursionlimit] command to
set/query the recursion limit of an interpreter. Proposal and
implementation from Stephen Trier. [TIP 87, Patch 522849]
2002-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tcl.h, tools/tcl.wse.in, unix/configure.in,
* unix/tcl.spec, win/README.binary, win/configure.in, README:
Bumped patchlevel; this might need to change in the future, but it
will help us distinguish between the CVS version and the most
recent released version.
2002-03-06 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclInt.h: for unshared objects, TclDecrRefCount now frees
the internal rep before the string rep - just like the non-macro
Tcl_DecrRefCount/TclFreeObj [Bug 524802].
2002-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/lsearch.n: Documentation of new features, plus examples.
* tests/lsearch.test: Tests of new features.
* generic/tclCmdIL.c (Tcl_LsearchObjCmd): TIP#80 support. See
http://purl.org/tcl/tip/80 for details.
2002-03-05 Jeff Hobbs <jeffh@ActiveState.com>
*** 8.4a4 TAGGED FOR RELEASE ***
* unix/tclUnixChan.c: initial remedy for [Bug 525783] flush problem
introduced by TIP #35. This may not satisfy true serial channels, but
it restores the correct flushing of std* channels on exit.
* unix/README: added --enable-langinfo doc.
* unix/tcl.spec:
* tools/tcl.wse.in: fixed URL refs to use www.tcl.tk or SF.
2002-03-04 Jeff Hobbs <jeffh@ActiveState.com>
|
| ︙ | ︙ | |||
4387 4388 4389 4390 4391 4392 4393 | * unix/Makefile.in: added older ChangeLogs to dist target. * tests/io.test: * tests/encoding.test: corrected iso2022 encoding results. added encoding-24.* * generic/tclEncoding.c (EscapeFromUtfProc): corrected output of | | | | | | | | | | | | | | | | | | | < | | | | | | | | < | | | | | | | | | | | | < | | | | | | | | | | | | | | < | | | | | | < | 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 9147 9148 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 9162 9163 9164 9165 9166 9167 9168 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 | * unix/Makefile.in: added older ChangeLogs to dist target. * tests/io.test: * tests/encoding.test: corrected iso2022 encoding results. added encoding-24.* * generic/tclEncoding.c (EscapeFromUtfProc): corrected output of escape codes as per RFC 1468. [Patch 474358] (taguchi) (TclFinalizeEncodingSubsystem): corrected potential double-free when encodings were finalized on exit. [Bug 219314, 524674] 2002-03-01 Jeff Hobbs <jeffh@ActiveState.com> * library/encoding/iso2022-jp.enc: * library/encoding/iso2022.enc: * tools/encoding/iso2022-jp.esc: * tools/encoding/iso2022.esc: gave <ESC>$B precedence over <ESC>$@, based on comments (point 1) in [Bug 219283] (RFC 1468) * tests/encoding.test: added encoding-23.* tests * generic/tclIO.c (FilterInputBytes): reset the TCL_ENCODING_START flags in the ChannelState when using 'gets'. [Bug 523988] Also reduced the value of ENCODING_LINESIZE from 30 to 20 as this seems to improve the performance of 'gets' according to tclbench. 2002-02-28 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclCmdMZ.c (TraceCommandProc): ensure that TraceCommandInfo structure was also deleted when a command was deleted to prevent a mem leak. * generic/tclBasic.c (Tcl_CreateObjTrace): set tracePtr->flags correctly. * generic/tclTimer.c (TimerExitProc): remove remaining events in tls on thread exit. 2002-02-28 Miguel Sofer <msofer@users.sourceforge.net> * generic/tclNamesp.c: allow cached fully-qualified namespace names to be usable from different namespaces within the same interpreter without forcing a new lookup [Patch 458872]. 2002-02-28 Miguel Sofer <msofer@users.sourceforge.net> * generic/tclExecute.c: Replaced a few direct stack accesses with the POP_OBJECT() macro [Bug 507181] (Don Porter). 2002-02-27 Don Porter <dgp@users.sourceforge.net> * doc/GetIndex.3: * generic/tcl.decls (Tcl_GetIndexFromObjStruct): * generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): Revised the prototype of the Tcl_GetIndexFromObjStruct to take its struct table as a (CONST VOID *) argument, better describing what it is, maintaining source compatibility, and adding CONST correctness according to TIP 27. Thanks to Joe English for an elegant solution. [Bug 520304] * generic/tclDecls.h: make genstubs * generic/tclMain.c (Tcl_Main,StdinProc): Corrected some reference count management errors on the interactive command Tcl_Obj found by Purify. Thanks to Jeff Hobbs for the report and assistance. 2002-02-27 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclBasic.c (Tcl_EvalTokensStandard): corrected mem leak in error case. * generic/tclTest.c (TestStatProc[123]): correct harmless UMRs. * generic/tclLink.c (Tcl_LinkVar): correct mem leak in error case. 2002-02-27 Andreas Kupries <andreas_kupries@users.sourceforge.net> * tests/socket.test (2.7): Accepted and applied patch for [Bug 523470] provided by Don Porter <dgp@users.sourceforge.net> to avoid timing problems in that test. * unix/tclUnixChan.c (TclpOpenFileChannel): Added code to regonize "/dev/tty" (by name) and to not handle it as tty / serial line. This is the controlling terminal and is special. Setting it into raw mode as is done for other tty's is a bad idea. This is a hackish fix for expect [Bug 520624]. The fix has limitation: Tcl_MakeFileChannel handles tty's specially too, but is unable to recognize /dev/tty as it only gets a file descriptor, and no name for it. 2002-02-26 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclCmdAH.c (StoreStatData): corrected mem leak. * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): prevent obj leak in remedial regsub case. * generic/tclFileName.c (Tcl_TranslateFileName): decr refcount for error case to prevent mem leak. * generic/tclVar.c (Tcl_ArrayObjCmd): removed extra obj allocation. * unix/tclUnixSock.c (Tcl_GetHostName): added an extra gethostbyname check to guard against failure with truncated names returned by uname. * unix/configure: * unix/tcl.m4 (SC_SERIAL_PORT): added sys/modem.h check and defined _XOPEN_SOURCE_EXTENDED for HP-11 to get updated header decls. * unix/tclUnixChan.c: added Unix implementation of TIP #35, serial port support. [Patch 438509] (schroedter) 2002-02-26 Miguel Sofer <msofer@users.sourceforge.net> * generic/tclCmpCmds.c: (bugfix to the bugfix, hopefully the last) Bugfix to the new [for] compiling code: was setting a exceptArray parameter using another param which wasn't yet initialised, thus filling it with noise. 2002-02-25 Andreas Kupries <andreas_kupries@users.sourceforge.net> * mac/tclMacSock.c (TcpGetOptionProc): Changed to recognize the option "-error". Essentially ignores the option, always returning an empty string. 2002-02-25 Jeff Hobbs <jeffh@ActiveState.com> * doc/Alloc.3: * doc/LinkVar.3: * doc/ObjectType.3: * doc/PkgRequire.3: * doc/Preserve.3: * doc/TCL_MEM_DEBUG.3: Updated documentation to describe the ckalloc, ckfree, ckrealloc, attemptckalloc, and attemptckrealloc macros, and to accurately describe when and how they are used. [Bug 497459] (dgp) * generic/tclHash.c (AllocArrayEntry, AllocStringEntry): Before invoking ckalloc when creating a Tcl_HashEntry, check that the amount of memory being allocated is at least as large as sizeof(Tcl_HashEntry). The previous code was allocating memory regions that were one or two bytes short. [Bug 521950] (dejong) 2002-02-25 Miguel Sofer <msofer@users.sourceforge.net> * generic/tclBasic.c (Tcl_EvalEx): avoiding a buffer overrun reported by Joe English, and restoring tcl7.6 behaviour for [subst]: badly terminated nested scripts will raise an error and not be evaluated. [Bug 495207] 2002-02-25 Don Porter <dgp@users.sourceforge.net> * unix/tclUnixPort.h: corrected strtoll prototype mismatch on Tru64. * compat/strtod.c (strtod): simplified #includes * compat/strtol.c (strtol): gather result in a long before returning as a long: necessary on platforms where sizeof(int) != sizeof(long). 2002-02-25 Daniel Steffen <das@users.sourceforge.net> * unix/tclLoadDyld.c: updated to use Mac OS X 10.1 dyld APIs that have more libdl-like semantics. [Bug 514392] 2002-02-25 Miguel Sofer <msofer@users.sourceforge.net> * generic/tclCompCmds: fixing a bug in patch dated 2002-02-22, in the code for [for] and [while]. Under certain conditions, for long bodies, the exception range parameters were badly computed. Tests forthcoming: I still can't reproduce the conditions in the testsuite (!), although the bug (with assorted segfault or panic!) can be triggered from the console or with the new parse.bench in tclbench. 2002-02-25 Donal K. Fellows <fellowsd@cs.man.ac.uk> * compat/strtoul.c, compat/strtol.c, compat/strtod.c: Added UCHAR, CONST and #includes to clean up GCC output. 2002-02-23 Don Porter <dgp@users.sourceforge.net> * compat/strtoull.c (strtoull): * compat/strtoll.c (strtoll): * compat/strtoul.c (strtoul): Fixed failure to handle leading sign symbols '+' and '-' and '0X' and raise overflow errors. [Bug 440916] Also corrects prototype and errno problems. 2002-02-23 Mo DeJong <mdejong@users.sourceforge.net> * configure: Regen. * unix/tcl.m4 (SC_CONFIG_CFLAGS): Link with -n32 instead of -32 when building on IRIX64-6.* system. [Bug 521707] 2002-02-22 Don Porter <dgp@users.sourceforge.net> * generic/tclInt.h: * generic/tclObj.c: renamed global variable emptyString -> tclEmptyString because it is no longer static. * generic/tclPkg.c: Fix for panic when library is loaded on a |
| ︙ | ︙ | |||
4593 4594 4595 4596 4597 4598 4599 | * unix/tcl.m4: added --enable-64bit support for AIX-4 (using -q64 flag) when using IBM's xlc compiler. * tests/safe.test: updated safe-8.5 and safe-8.7 * library/safe.tcl (CheckFileName): removed the limit on sourceable file names (was only *.tcl or tclIndex files with no more than one dot and 14 chars). There is enough internal | | | | | | | | | | < | | | | | | | | < | | | < | | | | | | | | | | | | | | < | | | > | | | | | | | | | | | | | | | | | < | | < | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | < | | 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 9213 9214 9215 9216 9217 9218 9219 9220 9221 9222 9223 9224 9225 9226 9227 9228 9229 9230 9231 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 9247 9248 9249 9250 9251 9252 9253 9254 9255 9256 9257 9258 9259 9260 9261 9262 9263 9264 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 9317 9318 9319 9320 9321 9322 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 9344 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 9357 9358 9359 9360 9361 9362 9363 9364 9365 9366 9367 9368 9369 9370 9371 9372 9373 9374 9375 9376 9377 9378 9379 9380 9381 9382 9383 9384 9385 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 | * unix/tcl.m4: added --enable-64bit support for AIX-4 (using -q64 flag) when using IBM's xlc compiler. * tests/safe.test: updated safe-8.5 and safe-8.7 * library/safe.tcl (CheckFileName): removed the limit on sourceable file names (was only *.tcl or tclIndex files with no more than one dot and 14 chars). There is enough internal protection in a safe interpreter already. Fixes [Tk Bug 521560]. 2002-02-22 Miguel Sofer <msofer@users.sourceforge.net> * generic/tclCompCmds: [FR 465811]. Optimising [if], [for] and [while] for constant conditions; in addition, [for] and [while] are now compiled with the "loop rotation" optimisation (thanks to Kevin Kenny). 2002-02-22 Donal K. Fellows <fellowsd@cs.man.ac.uk> --- TIP#76 CHANGES --- * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): Final-argument-less [regsub] returns the modified string. * doc/regsub.n: Updated docs. * tests/regexp.test: Updated and added tests. * compat/strtoll.c (strtoll): * compat/strtoull.c (strtoull): * unix/tclUnixPort.h: * win/tclWinPort.h: Const-ing 64-bit compatability declarations. Note that the return pointer is non-const because it is entirely legal for the functions to be called from somewhere that owns the string being passed. Fixes problem reported by Larry Virden. 2002-02-21 David Gravereaux <davygrvy@pobox.com> * win/mkd.bat (removed): * win/coffbase.txt (new): * win/makefile.bc: * win/makefile.vc: Changed the 'setup' target to stop using the mkd.bat file and just make the directory right in the rule. Same change to makefile.bc. configure.in nor Makefile.in use it. coffbase.txt will be the master list for our "prefered base addresses" set by the linker. This should improve load-time (NT only) by avoiding relocations. Submissions to the list by extension authors are encouraged. Added a 'tidy' target to compliment 'clean' and 'hose' to remove just the outputs. Also removed the $(winlibs) macro as it wasn't being used. Stuff left to do: 1) get the winhelp target to stop building in the tools/ directory. 2) stop using rmd.bat 3) add more dependacy rules. * win/tclAppInit.c: Reverted back to -r1.6, as the header file change to tclPort.h won't allow for easy embedded support outside of the source dist. Thanks to Don Porter for pointing this out to me. 2002-02-21 David Gravereaux <davygrvy@pobox.com> * win/makefile.vc: * win/rules.vc: Added a new "loimpact" option that sets the -ws:aggressive linker option. Off by default. It's said to keep the heap use low at the expense of alloc speed. * win/tclAppInit.c: Changed #include "tcl.h" to be tclPort.h to remove the raw windows.h include. tclPort.h brings in windows.h already and lessens the pre-compiled-header mush and the randomly useless #pragma comment (lib,...) references throughout the big windows.h tree (as observed at high linker warning levels). 2002-02-21 Donal K. Fellows <fellowsd@cs.man.ac.uk> * generic/tcl.h: Better guessing of LP64/ILP32 architecture, but now sensitive to presence of (suitable) <limits.h> 2002-02-20 Don Porter <dgp@users.sourceforge.net> * generic/tcl.decls (Tcl_RegExpRange,Tcl_GetIndexFromObjStruct): Overlooked a few source incompatibilities. Now using CONST84. * generic/tclDecls.h: make genstubs * generic/tcl.h (Tcl_CmdObjTraceProc): silence warning from Sun Workshop compiler. 2002-02-20 David Gravereaux <davygrvy@pobox.com> * win/buildall.vc.bat: * win/makefile.vc: * win/rules.vc: General clean-ups. Added compiler and linker tests for a) the pentium 0x0F errata, b) optimizing (not all have this), and c) linker v6 section alignment confusion. All these are tested first to make sure any D4002 or LNK1117 warnings aren't displayed. The pentium 0x0F errata is a recommended switch. The v5 linker's section alignment default is 512, but the v6 linker was changed to 4096 in an attempt to speed loading on Win98. I changed the default to always be 512 across both linkers, unless linking statically, then 4096 is used for the claimed speed effect. Using a 512 alignment saves 12k bytes of dead space in the DLL. Added IA64 B-stepping errata switch when the compiler supports it. Added profiling to $(lflags) when requested and also removed the explict -entry option as the default works fine as is. Removed win/tclWinInit.c from the special case section to let it use the common implicit rule as the $(EXTFLAGS) macro it had was never referenced anywhere. 2002-02-20 Donal K. Fellows <fellowsd@cs.man.ac.uk> * generic/tcl.h: Added code to guess the correct settings for TCL_WIDE_INT_IS_LONG and TCL_WIDE_INT_TYPE when configure doesn't tell us them, as can happen with extensions. 2002-02-19 Donal K. Fellows <fellowsd@cs.man.ac.uk> * doc/format.n: Updated docs to list the specification. * generic/tclCmdAH.c (Tcl_FormatObjCmd): Made behaviour on 64-bit platforms correctly meet the specification, that %d works with the native word-sized integer, instead of trying to guess (wrongly) from the value being passed. 2002-02-19 Don Porter <dgp@users.sourceforge.net> * changes: First draft of updated changes for 8.4a4 release. 2002-02-15 Jeff Hobbs <jeffh@ActiveState.com> * unix/tclUnixPort.h: add strtoll/strtoull declarations for platforms that do not define them. * generic/tclIndexObj.c (STRING_AT): removed ptrdiff_t cast and use of VOID* in default case (GNU-ism). 2002-02-15 Kevin Kenny <kennykb@acm.org> * compat/strtoll.c: * compat/strtoul.c: * compat/strtoull.c: * generic/tclIOUtil.c: * generic/tclPosixStr.c: * generic/tclTest.c: * generic/tclTestObj.c: * tests/get.test: * win/Makefile.vc: Further tweaks to the TIP 72 patch to make it compile under VC++. 2002-02-15 Andreas Kupries <andreas_kupries@users.sourceforge.net> * tclExecute.c: * tclIOGT.c: * tclIndexObj.c: Touchups to the TIP 72 patch to make it compileable under Windows again. The changes are not complete, there is one nasty regarding _stati64 2002-02-15 Donal K. Fellows <fellowsd@cs.man.ac.uk> +----------------------+ | TIP #72 IMPLEMENTED. | +----------------------+ There are a lot of changes from this TIP, so please see http://tip.tcl.tk/72.html for discussion of backward-compatability issues, but the main ones modifications are in: * generic/tcl.h: New types. * generic/tcl.decls: New public functions. * generic/tclExecute.c: 64-bit aware bytecode engine. * generic/tclBinary.c: 64-bit handling in [binary] command. * generic/tclScan.c: 64-bit handling in [scan] command. * generic/tclCmdAH.c: 64-bit handling in [file] and [format] commands. * generic/tclBasic.c: New "wordSize" entry in ::tcl_platform. * generic/tclFCmd.c: Large-file support (with many consequences.) * generic/tclIO.c: Large-file support (with many consequences.) * compat/strtoll.c, compat/strtoull.c: New support functions. * unix/tcl.m4, unix/configure: 64-bit support and greatly enhanced cacheing. Most other changes, including all those in doc/* and test/* as well as the majority in the platform directories, follow on from these. Also coming out of the woodwork: * generic/tclIndex.c: Better support for Cray PVP. * win/tclWinMtherr.c: Better Borland support. Note that, in a number of places through the Unix part of the platform support, there are Tcl_Platform* references. These are expanded into the correct way to call that particular underlying function, i.e. with or without a '64' suffix, and should be used by people working on the core in preference to the API functions they overlay so that the code remains portable depending on the presence or absence of 64-bit support on the underlying platform. ***POTENTIAL INCOMPATIBILITY***: Extracted from the TIP SUMMARY OF INCOMPATIBILITIES AND FIXES ====================================== The behaviour of expressions containing constants that appear positive but which have a negative internal representation will change, as these will now usually be interpreted as wide integers. This is always fixable by replacing the constant with int(constant). Extensions creating new channel types will need to be altered as different types are now in use in those areas. The change to the declaration of Tcl_FSStat and Tcl_FSLstat (which are the new preferred API in any case) are less serious as no non-alpha releases have been made yet with those API functions. Scripts that are lax about the use of the l modifier in format and scan will probably need to be rewritten. This should be very uncommon though as previously it had absolutely no effect. Extensions that create new math functions that take more than one argument will need to be recompiled (the size of Tcl_Value changes), and functions that accept arguments of any type (TCL_EITHER) will need to be rewritten to handle wide integer values. (I do not expect this to affect many extensions at all.) 2002-02-14 Andreas Kupries <andreas_kupries@users.sourceforge.net> * generic/tclIOCmd.c (Tcl_GetsObjCmd): Trivial fix for [Bug 517503], a memory leak reported by Miguel Sofer <msofer@users.sourceforge.net>. The leak happens if an error occurs for "set var [gets $chan]" and leak one empty object. 2002-02-12 David Gravereaux <davygrvy@pobox.com> * djgpp/ (new directory) * djgpp/Makefile (new): * unix/tclAppInit.c: * unix/tclMtherr.c: * unix/tclUnixFCmd.c: * unix/tclUnixFile.c: * unix/tclUnixInit.c: * unix/tclUnixPort.h: Early stage of DJGPP support for building Tcl on DOS. Dynamic loading isn't working, yet. Requires watt32 for the TCP/IP stack. No autoconf, yet. Barely tested, but makes a working exe that runs Tcl in protected-mode, flat memory. [exec] and pipes will need the most work as multi-tasking on DOS has to be carefully. 2002-02-10 Kevin Kenny <kennykb@acm.org> * doc/CrtObjCmd.3: * doc/CrtTrace.3: * generic/tcl.decls: * generic/tcl.h: * generic/tclBasic.c: * generic/tclInt.h: * generic/tclTest.c: * tests/basic.test: Added Tcl_CreateObjTrace, Tcl_GetCommandInfoFromToken and Tcl_SetCommandInfoFromToken. (TIPs #32 and #79.) * generic/tclDecls.h: * generic/tclStubInit.c: Regenerated Stubs tables. 2002-02-08 Jeff Hobbs <jeffh@ActiveState.com> * unix/configure: * unix/tcl.m4: added -pthread for FreeBSD to EXTRA_CFLAGS and LDFLAGS. Also triggered nodots only for FreeBSD-3. Added AC_DEFINE(_POSIX_PTHREAD_SEMANTICS) for Solaris. |
| ︙ | ︙ | |||
4893 4894 4895 4896 4897 4898 4899 | * win/tclWin32Dll.c: * win/tclWinFCmd.c: * win/tclWinFile.c: * win/tclWinInit.c: Partial TIP 27 rollback. Following routines restored to return (char *): Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_JoinPath, Tcl_TranslateFileName, Tcl_ExternalToUtfDString, Tcl_UtfToExternalDString, | | | | | | | 9483 9484 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 | * win/tclWin32Dll.c: * win/tclWinFCmd.c: * win/tclWinFile.c: * win/tclWinInit.c: Partial TIP 27 rollback. Following routines restored to return (char *): Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_JoinPath, Tcl_TranslateFileName, Tcl_ExternalToUtfDString, Tcl_UtfToExternalDString, Tcl_UniCharToUtfDString, Tcl_GetCwd, Tcl_WinTCharToUtf. Also restored Tcl_WinUtfToTChar to return (TCHAR *) and Tcl_UtfToUniCharDString to return (Tcl_UniChar *). Modified some callers. This change recognizes that Tcl_DStrings are de-facto white-box objects. * generic/tclDecls.h: * generic/tclPlatDecls.h: make genstubs * generic/tclCmdMZ.c: corrected use of C++-style comment. 2002-02-06 Jeff Hobbs <jeffh@ActiveState.com> * tests/scan.test: * generic/tclScan.c (Tcl_ScanObjCmd): corrected scan 0x... %x handling that didn't accept the 0x as a prelude to a base 16 number. [Bug 495213] * generic/tclCompCmds.c (TclCompileRegexpCmd): made early check for bad RE to stop checking further. * generic/tclCmdMZ.c (Tcl_RegsubObjCmd): added special case to search for simple 'string map' style regsub calls. Delayed creation of resultPtr object until an initial match is |
| ︙ | ︙ | |||
4936 4937 4938 4939 4940 4941 4942 | * library/http/http.tcl: * library/http/pkgIndex.tcl: Corrected use of http::error when ::error was intended. Bump to http 2.4.2. 2002-02-04 Andreas Kupries <andreas_kupries@users.sourceforge.net> | | | | | | < | | | | | | | | | | | | | | < | | | | < | | | < | | 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 9543 9544 9545 9546 9547 9548 9549 9550 9551 9552 9553 9554 9555 9556 9557 9558 9559 9560 9561 9562 9563 9564 9565 9566 9567 9568 9569 9570 9571 9572 9573 9574 9575 9576 9577 9578 9579 9580 9581 9582 9583 9584 9585 9586 9587 9588 9589 9590 9591 9592 9593 9594 9595 9596 9597 9598 9599 9600 9601 9602 9603 9604 | * library/http/http.tcl: * library/http/pkgIndex.tcl: Corrected use of http::error when ::error was intended. Bump to http 2.4.2. 2002-02-04 Andreas Kupries <andreas_kupries@users.sourceforge.net> * unix/tclUnixChan.c (FileOutputProc): Fixed [bug 465765] reported by Dale Talcott <daletalcott@users.sourceforge.net>. Avoid writing nothing into a file as STREAM based implementations will consider this a EOF (if the file is a pipe). Not done in the generic layer as this type of writing is actually useful to check the state of a socket. * doc/open.n: Fixed [Bug 511540], added cross-reference to 'pid' as the command to use to retrieve the pid of a command pipeline created via 'open'. 2002-02-01 Jeff Hobbs <jeffh@ActiveState.com> * generic/tclCmdMZ.c (Tcl_RegexpObjCmd): handle quirky about case earlier to avoid shimmering problem. 2002-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net> * tests/io.test: io-39.22 split into two tests, one platform dependent, the other not. -eofchar is not empty on the windows platform. 2002-02-01 Vince Darley <vincentdarley@users.sourceforge.net> * generic/tclTest.c: fix to picky windows compiler problem with the 'MainLoop' function declaration. 2002-01-31 Andreas Kupries <andreas_kupries@users.sourceforge.net> * win/tclWinFCmd.c: TIP 27: Applied patch fixing CONST warnings on behalf of Don Porter <dgp@users.sourceforge.net>. 2002-01-30 Don Porter <dgp@users.sourceforge.net> * generic/tcl.decls: * generic/tcl.h: * generic/tclInt.h: For each interface identified in the TIP 27 changes below as a POTENTIAL INCOMPATIBILITY, the source of the incompatibility has been parameterized so that it can be removed. When compiling extension code against the Tcl header files, use the compiler flag -DUSE_NON_CONST to remove the irresolvable source incompatibilities introduced by the TIP 27 changes. Resolvable changes are left for extension authors to resolve. * generic/tclDecls.h: make genstubs 2002-01-30 Vince Darley <vincentdarley@users.sourceforge.net> * doc/FileSystem.3: added documentation for 3 public functions which had been overlooked. Fixes [Bug 507701] * unix/mkLinks: make mklinks 2002-01-29 Jeff Hobbs <jeffh@ActiveState.com> * tests/regexpComp.test: * generic/tclCompCmds.c (TclCompileRegexpCmd): enhanced to support -nocase and -- options. 2002-01-28 Mo DeJong <mdejong@users.sourceforge.net> * unix/tcl.m4 (SC_LOAD_TCLCONFIG): * win/tcl.m4 (SC_LOAD_TCLCONFIG): Set TCL_LIB_SPEC, TCL_STUB_LIB_SPEC, and TCL_STUB_LIB_PATH to the values of TCL_BUILD_LIB_SPEC, TCL_BUILD_STUB_LIB_SPEC, and TCL_BUILD_STUB_LIB_PATH when tclConfig.sh is loaded from the build directory. A Tcl extension should make use of the non-build versions of these variables since they will work in both cases. This modification was described in TIP #34. 2002-01-28 Jeff Hobbs <jeffh@ActiveState.com> * win/tclWinReg.c (regConnectRegistryProc,RecursiveDeleteKey) (DeleteKey,GetKeyNames,GetType,GetValue,OpenSubKey,SetValue): redid the CONSTification as previous changes caused failing tests. |
| ︙ | ︙ | |||
5034 5035 5036 5037 5038 5039 5040 | * win/tclWinInit.c (TclpFindVariable): CONSTification touch-up * win/tclWinReg.c (OpenSubKey): corrected bug introduced in CONSTification that dropped pointer reference. * ChangeLog.2000 (new file): * ChangeLog: broke changes from 2000 into ChangeLog.2000 to reduce | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | 9620 9621 9622 9623 9624 9625 9626 9627 9628 9629 9630 9631 9632 9633 9634 9635 9636 9637 9638 9639 9640 9641 9642 9643 9644 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 9660 9661 9662 9663 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 9701 9702 9703 9704 | * win/tclWinInit.c (TclpFindVariable): CONSTification touch-up * win/tclWinReg.c (OpenSubKey): corrected bug introduced in CONSTification that dropped pointer reference. * ChangeLog.2000 (new file): * ChangeLog: broke changes from 2000 into ChangeLog.2000 to reduce size of the main ChangeLog. 2002-01-28 David Gravereaux <davygrvy@pobox.com> * generic/tclPlatDecls.h: Added preprocessor logic to force a typedef of TCHAR when __STDC__ is defined when using the uncommon -Za compiler switch with the microsoft compiler. 2002-01-27 Don Porter <dgp@users.sourceforge.net> * doc/package.n: Documented global namespace context for script evaluation by [package require]. 2002-01-27 Daniel Steffen <das@users.sourceforge.net> * generic/tclInt.decls: * generic/tclIntPlatDecls.h: * mac/tclMacChan.c: * mac/tclMacFCmd.c: * mac/tclMacFile.c: * mac/tclMacInit.c: * mac/tclMacLoad.c: * mac/tclMacResource.c: * mac/tclMacSock.c: TIP 27 CONSTification induced changes * tests/event.test: * tests/main.test: added catches/constraints to test that use features that don't exist on the mac. 2002-01-25 Mo DeJong <mdejong@users.sourceforge.net> Make -eofchar and -translation options read only for server sockets. [Bug 496733] * generic/tclIO.c (Tcl_GetChannelOption, Tcl_SetChannelOption): Instead of returning nothing for the -translation option on a server socket, always return "auto". Return the empty string enclosed in quotes for the -eofchar option on a server socket. Fixup -eofchar usage message so that it matches the implementation. * tests/io.test: Add -eofchar tests and -translation tests to ensure options are read only on server sockets. * tests/socket.test: Update tests to account for -eofchar and -translation option changes. 2002-01-25 Don Porter <dgp@users.sourceforge.net> * compat/strstr.c (strstr): * generic/tclCmdAH.c (Tcl_FormatObjCmd): * generic/tclCmdIL.c (InfoNameOfExecutableCmd): * generic/tclEnv.c (ReplaceString): * generic/tclFileName.c (ExtractWinRoot): * generic/tclIO.c (FlushChannel,Tcl_BadChannelOption): * generic/tclStringObj.c (AppendUnicodeToUtfRep): * generic/tclThreadTest.c (TclCreateThread): * generic/tclUtf.c (Tcl_UtfPrev): * mac/tclMacFCmd.c (TclpObjListVolumes): * mac/tclMacResource.c (TclMacRegisterResourceFork) (BuildResourceForkList): * win/tclWinInit.c (AppendEnvironment): Sought out and eliminated instances of CONST-casting that are no longer needed after the TIP 27 effort. * Following is [Patch 501006] * generic/tclInt.decls (Tcl_AddInterpResolvers, Tcl_Export) (Tcl_FindNamespace, Tcl_GetInterpResolvers, Tcl_ForgetImport) (Tcl_Import, Tcl_RemoveInterpResolvers): * generic/tclNamesp.c (Tcl_Export, Tcl_Import, Tcl_ForgetImport) (Tcl_FindNamespace): * generic/tclResolve.c (Tcl_AddInterpResolvers,Tcl_GetInterpResolvers, (Tcl_RemoveInterpResolvers): Updated APIs in generic/tclResolve.c and generic/tclNamesp.c according to the guidelines of TIP 27. * generic/tclIntDecls.h: make genstubs * Following is [Patch 505630] * doc/AddErrorInfo.3: * generic/tcl.decls (Tcl_LogCommandInfo): * generic/tclBasic.c (Tcl_LogCommandInfo): Updated interfaces of generic/tclBasic.cc according to TIP 27. |
| ︙ | ︙ | |||
5138 5139 5140 5141 5142 5143 5144 | * doc/Encoding.3: * generic/tcl.decls (Tcl_WinUtfToTChar,Tcl_WinTCharToUtf): * win/tclWin32Dll.c (Tcl_WinUtfToTChar,Tcl_WinTCharToUtf): Updated interfaces in win/tclWin32Dll.c according to TIP 27. * generic/tclPlatDecls.h: make genstubs * generic/tclIOUtil.c (TclpNativeToNormalized): * win/tclWinFCmd.c (TclpObjNormalizePath): | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | < | | | | | | | | | | | | | | | < | | | | | | < | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | > | | | | | < | | | | | | | | | < | | | | | | | | | | | | | > | | | | | | | | > | | | | | | | | | | | | | | | | | | | | 9723 9724 9725 9726 9727 9728 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 9742 9743 9744 9745 9746 9747 9748 9749 9750 9751 9752 9753 9754 9755 9756 9757 9758 9759 9760 9761 9762 9763 9764 9765 9766 9767 9768 9769 9770 9771 9772 9773 9774 9775 9776 9777 9778 9779 9780 9781 9782 9783 9784 9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 9801 9802 9803 9804 9805 9806 9807 9808 9809 9810 9811 9812 9813 9814 9815 9816 9817 9818 9819 9820 9821 9822 9823 9824 9825 9826 9827 9828 9829 9830 9831 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 9846 9847 9848 9849 9850 9851 9852 9853 9854 9855 9856 9857 9858 9859 9860 9861 9862 9863 9864 9865 9866 9867 9868 9869 9870 9871 9872 9873 9874 9875 9876 9877 9878 9879 9880 9881 9882 9883 9884 9885 9886 9887 9888 9889 9890 9891 9892 9893 9894 9895 9896 9897 9898 9899 9900 9901 9902 9903 9904 9905 9906 9907 9908 9909 9910 9911 9912 9913 9914 9915 9916 9917 9918 9919 9920 9921 9922 9923 9924 9925 9926 9927 9928 9929 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 9950 9951 9952 9953 9954 9955 9956 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 9970 9971 9972 9973 9974 9975 9976 9977 9978 9979 9980 9981 9982 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 9993 9994 9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 10038 10039 10040 10041 10042 10043 10044 10045 10046 10047 10048 10049 10050 10051 10052 10053 10054 10055 10056 10057 10058 10059 10060 10061 10062 10063 10064 10065 10066 10067 10068 10069 10070 10071 10072 10073 10074 10075 10076 10077 10078 10079 10080 10081 10082 10083 10084 10085 10086 10087 10088 10089 10090 10091 10092 10093 10094 10095 10096 10097 10098 10099 10100 10101 10102 10103 10104 10105 10106 10107 10108 10109 10110 10111 10112 10113 10114 10115 10116 10117 10118 10119 10120 10121 10122 10123 10124 10125 10126 10127 10128 10129 10130 10131 10132 10133 10134 10135 10136 10137 10138 10139 10140 10141 10142 10143 10144 10145 10146 10147 10148 10149 10150 10151 10152 10153 10154 10155 10156 10157 10158 10159 10160 10161 10162 10163 10164 10165 10166 10167 10168 10169 10170 10171 10172 10173 10174 10175 10176 10177 10178 10179 10180 10181 10182 10183 10184 10185 10186 10187 10188 10189 10190 10191 10192 10193 10194 10195 10196 10197 10198 10199 10200 10201 10202 10203 10204 10205 10206 10207 10208 10209 10210 10211 10212 10213 10214 10215 10216 10217 10218 10219 10220 10221 10222 10223 10224 10225 10226 10227 10228 10229 10230 10231 10232 10233 10234 10235 10236 10237 10238 10239 10240 10241 10242 10243 10244 10245 10246 10247 10248 10249 10250 10251 10252 10253 10254 10255 10256 10257 10258 10259 10260 10261 10262 10263 10264 10265 10266 10267 10268 10269 10270 10271 10272 10273 10274 10275 10276 10277 10278 10279 10280 10281 10282 10283 10284 10285 10286 10287 10288 10289 10290 10291 10292 10293 10294 10295 10296 10297 10298 10299 10300 10301 10302 10303 10304 10305 10306 10307 10308 10309 10310 10311 10312 10313 10314 |
* doc/Encoding.3:
* generic/tcl.decls (Tcl_WinUtfToTChar,Tcl_WinTCharToUtf):
* win/tclWin32Dll.c (Tcl_WinUtfToTChar,Tcl_WinTCharToUtf):
Updated interfaces in win/tclWin32Dll.c according to TIP 27.
* generic/tclPlatDecls.h: make genstubs
* generic/tclIOUtil.c (TclpNativeToNormalized):
* win/tclWinFCmd.c (TclpObjNormalizePath):
* win/tclWinFile.c (TclpFindExecutable,TclpMatchInDirectory)
(NativeIsExec,NativeStat):
* win/tclWinLoad.c (TclpLoadFile):
* win/tclWinPipe.c (TclpOpenFile,ApplicationType):
* win/tclWinReg.c (regConnectRegistryProc,RecursiveDeleteKey,DeleteKey)
(GetKeyNames,GetType,GetValue,OpenSubKey,SetValue):
* win/tclWinSerial.c (SerialSetOptionProc): Update callers.
* Following is [Patch 505072]
* doc/Concat.3:
* doc/Encoding.3:
* doc/Filesystem.3:
* doc/Macintosh.3:
* doc/OpenFileChnl.3
* doc/SetResult.3:
* doc/SetVar.3:
* doc/SplitList.3:
* doc/SplitPath.3:
* doc/Translate.3:
* generic/tcl.h (Tcl_FSMatchInDirectoryProc):
* generic/tclInt.h (TclpMatchInDirectory):
* generic/tcl.decls (Tcl_Concat,Tcl_GetStringResult,Tcl_GetVar,
(Tcl_GetVar2,Tcl_JoinPath,Tcl_Merge,Tcl_OpenCommandChannel,Tcl_SetVar)
(Tcl_SetVar2,Tcl_SplitList,Tcl_SplitPath,Tcl_TranslateFileName)
(Tcl_ExternalToUtfDString,Tcl_GetEncodingName,Tcl_UtfToExternalDString)
(Tcl_GetDefaultEncodingDir,Tcl_SetDefaultEncodingDir)
(Tcl_FSMatchInDirectory,Tcl_MacEvalResource,Tcl_MacFindResource):
* generic/tclInt.decls (TclCreatePipeline,TclGetEnv,TclpGetCwd,
(TclpCreateProcess):
* mac/tclMacFile.c (TclpGetCwd):
* generic/tclEncoding.c (Tcl_GetDefaultEncodingDir)
(Tcl_SetDefaultEncodingDir,Tcl_GetEncodingName)
(Tcl_ExternalToUtfDString,Tcl_UtfToExternalDString, OpenEncodingFile)
(LoadEscapeEncoding):
* generic/tclFileName.c (DoTildeSubst,Tcl_JoinPath,Tcl_SplitPath,
(Tcl_TranslateFileName):
* generic/tclIOUtil.c (Tcl_FSMatchInDirectory):
* generic/tclPipe.c (FileForRedirect,TclCreatePipeline)
(Tcl_OpenCommandChannel):
* generic/tclResult.c (Tcl_GetStringResult):
* generic/tclUtil.c (Tcl_Concat,Tcl_SplitList,Tcl_Merge):
* generic/tclVar.c (Tcl_GetVar,Tcl_GetVar2,Tcl_SetVar,Tcl_SetVar2):
* mac/tclMacResource.c (Tcl_MacEvalResource,Tcl_MacFindResource):
Updated interfaces of generic/tclEncoding, generic/tclFilename.c,
generic/tclIOUtil.c, generic/tclPipe.c, generic/tclResult.c,
generic/tclUtil.c, generic/tclVar.c and mac/tclMacResource.c according
to TIP 27. Tcl_TranslateFileName rewritten as wrapper around
VFS-aware version.
***POTENTIAL INCOMPATIBILITY***
Includes source incompatibilities: argv arguments of Tcl_Concat,
Tcl_JoinPath, Tcl_OpenCommandChannel, Tcl_Merge; argvPtr arguments of
Tcl_SplitList and Tcl_SplitPath.
* generic/tclDecls.h:
* generic/tclIntDecls.h: make genstubs
* generic/tclCkalloc.c (MemoryCmd):
* generic/tclClock.c (FormatClock):
* generic/tclCmdAH.c (Tcl_CaseObjCmd,Tcl_EncodingObjCmd,Tcl_FileObjCmd):
* generic/tclCmdIL.c (InfoLibraryCmd,InfoPatchLevelCmd,
(InfoTclVersionCmd):
* generic/tclCompCmds.c (TclCompileForeachCmd):
* generic/tclCompCmds.h (TclCompileForeachCmd):
* generic/tclCompile.c (TclFindCompiledLocal):
* generic/tclEnv.c (TclSetupEnv,TclSetEnv,Tcl_PutEnv,TclGetEnv,
(EnvTraceProc):
* generic/tclEvent.c (Tcl_BackgroundError):
* generic/tclIO.c (Tcl_BadChannelOption,Tcl_SetChannelOption):
* generic/tclIOCmd.c (Tcl_ExecObjCmd,Tcl_OpenObjCmd):
* generic/tclIOSock.c (TclSockGetPort):
* generic/tclIOUtil.c (SetFsPathFromAny):
* generic/tclLink.c (LinkTraceProc):
* generic/tclMain.c (Tcl_Main):
* generic/tclNamesp.c (TclTeardownNamespace):
* generic/tclProc.c (TclCreateProc):
* generic/tclTest.c (TestregexpObjCmd,TesttranslatefilenameCmd,
(TestchmodCmd,GetTimesCmd,TestsetCmd,TestOpenFileChannelProc1,
(TestOpenFileChannelProc2,TestOpenFileChannelProc3,AsyncHandlerProc,
(TestpanicCmd):
* generic/tclThreadTest.c (ThreadErrorProc,ThreadEventProc):
* generic/tclUtil.c (TclPrecTraceProc):
* mac/tclMacFCmd.c (GetFileSpecs):
* mac/tclMacFile.c (TclpMatchInDirectory):
* mac/tclMacInit.c (TclpInitLibraryPath,Tcl_SourceRCFile):
* mac/tclMacOSA.c (tclOSAStore,tclOSALoad):
* mac/tclMacResource.c (Tcl_MacEvalResource):
* unix/tclUnixFCmd.c (TclpObjNormalizePath):
* unix/tclUnixFile.c (TclpMatchInDirectory,TclpGetUserHome,TclpGetCwd,
(TclpReadLink):
* unix/tclUnixInit.c (TclpInitLibraryPath,TclpSetVariables,
(Tcl_SourceRCFile):
* unix/tclUnixPipe.c (TclpOpenFile,TclpCreateTempFile,
(TclpCreateProcess):
* win/tclWinFile.c (TclpGetCwd,TclpMatchInDirectory):
* win/tclWinInit.c (TclpInitLibraryPath,Tcl_SourceRCFile,
(TclpSetVariables):
* win/tclWinPipe.c (TclpCreateProcess): Updated callers.
2002-01-24 Don Porter <dgp@users.sourceforge.net>
* generic/tclIOUtil.c (SetFsPathFromAny): Corrected tilde-substitution
of pathnames where > 1 separator follows the ~. [Bug 504950]
2002-01-24 Jeff Hobbs <jeffh@ActiveState.com>
* library/http/pkgIndex.tcl:
* library/http/http.tcl: don't add port in default case to handle
broken servers. http bumped to 2.4.1 [Bug 504508]
2002-01-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* unix/mkLinks: Regenerated.
* doc/CrtChannel.3:
* doc/ChnlStack.3: Moved documentation for 'Tcl_GetTopChannel' from
'CrtChannel' to 'ChnlStack'. Added documentation of
'Tcl_GetStackedChannel'. [Bug 506147] reported by Mark Patton
<msp@users.sourceforge.net>
2002-01-23 Don Porter <dgp@users.sourceforge.net>
* win/tclWinFile.c (NativeAccess,NativeStat,NativeIsExec,
(TclpGetUserHome):
* win/tclWinPort.h (TclWinSerialReopen):
* win/tclWinSerial.c (TclWinSerialReopen):
* win/tclWinSock.c (Tcl_OpenTcpServer): Corrections to earlier TIP
#27 changes. Thanks to Andreas Kupries for the feedback.
* generic/tclPlatDecls.h: make genstubs
* doc/GetHostName.3:
* doc/GetOpnFl.3:
* doc/OpenTcp.3:
* tcl.decls (Tcl_GetHostName,Tcl_GetOpenFile,Tcl_OpenTcpClient,
(Tcl_OpenTclServer):
* mac/tclMacSock.c (CreateSocket,Tcl_OpenTcpClient,Tcl_OpenTcpServer,
(Tcl_GetHostName,GetHostFromString):
* unix/tclUnixChan.c (CreateSocket,CreateSocketAddress,
(Tcl_OpenTcpClient,Tcl_OpenTcpServer,Tcl_GetOpenFile):
* unix/tclUnixSock.c (Tcl_GetHostName):
* win/tclWinSock.c (CreateSocket,CreateSocketAddress,
(Tcl_OpenTcpClient,Tcl_OpenTcpServer,Tcl_GetHostName):
Updated socket interfaces according to TIP 27.
* generic/tclCmdIL.c (InfoHostnameCmd): Updated callers.
* generic/tclDecls.h: make genstubs
2002-01-21 David Gravereaux <davygrvy@pobox.com>
* generic/tclLoadNone.c: TclpLoadFile() didn't match proto of typedef
Tcl_FSLoadFileProc. OK'd by vincentdarley. [Patch 502488]
2002-01-21 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclIO.c (WriteChars): Fix for [Bug 506297], reported by
Martin Forssen <ruric@users.sourceforge.net>. The encoding chosen in
the script exposing the bug writes out three intro characters when
TCL_ENCODING_START is set, but does not consume any input as
TCL_ENCODING_END is cleared. As some output was generated the
enclosing loop calls UtfToExternal again, again with START set. Three
more characters in the out and still no use of input ... To break this
infinite loop we remove TCL_ENCODING_START from the set of flags after
the first call (no condition is required, the later calls remove an
unset flag, which is a no-op). This causes the subsequent calls to
UtfToExternal to consume and convert the actual input.
2002-01-21 Don Porter <dgp@users.sourceforge.net>
* generic/tclTest.c: Converted declarations of TestReport file system
to more portable form. [Bug 501417].
* generic/tcl.decls (Tcl_TraceCommand,Tcl_UntraceCommand,
(Tcl_CommandTraceInfo):
* generic/tclCmdMZ.c (Tcl_TraceCommand,Tcl_UntraceCommand,
(Tcl_CommandTraceInfo): Updated APIs in generic/tclCmdMZ.c
according to the guidelines of TIP 27.
* generic/tclDecls.h: make genstubs
2002-01-18 Don Porter <dgp@users.sourceforge.net>
* win/tclWinChan.c:
* win/tclWinFCmd.c:
* win/tclWinFile.c: Overlooked callers of Tcl_FSGetNativePath
* win/tclWinDde.c:
* win/tclWinReg.c: Overlooked callers of Tcl_GetIndexFromObj
2002-01-18 Daniel Steffen <das@users.sourceforge.net>
* generic/tclThreadTest.c:
* mac/tclMacChan.c:
* mac/tclMacFCmd.c:
* mac/tclMacFile.c:
* mac/tclMacLoad.c:
* mac/tclMacResource.c: TIP 27 CONSTification broke the mac build in a
number of places.
2002-01-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclIOCmd.c (Tcl_GetsObjCmd): Fixed [Bug 504642] as reported
by Brian Griffin <bgriffin@users.sourceforge.net>, using his patch.
Before the patch the generic I/O layer held an unannounced reference
to the interp result to store the read line into. This unfortunately
has disastrous results if the channel driver executes a Tcl script to
perform its operation, this freeing the interp result. In that case we
are dereferencing essentially a dangling reference. It is not truly
dangling because the object is in the free list, but this only causes
us to smash the free list and have the error occur later somewhere
else. The patch simply creates a new object for the line and later
sets it into the interp result when we are done with reading.
2002-01-16 Mo DeJong <mdejong@users.sourceforge.net>
* unix/tcl.m4 (SC_LOAD_TCLCONFIG):
* win/tcl.m4 (SC_LOAD_TCLCONFIG): Subst TCL_DBGX into
TCL_STUB_LIB_FILE and TCL_STUB_LIB_FLAG variables so that an extension
does not need to subst TCL_DBGX into its makefile. [Tk Bug 504356]
2002-01-16 Don Porter <dgp@users.sourceforge.net>
* doc/FileSystem.3:
* doc/GetCwd.3:
* doc/GetIndex.3:
* generic/tcl.decls (Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct,
(Tcl_GetCwd, Tcl_FSFileAttrStrings, Tcl_FSGetNativePath,
(Tcl_FSGetTranslatedStringPath):
* generic/tcl.h (Tcl_FSFileAttrStringsProc):
* generic/tclFCmd.c (TclFileAttrsCmd):
* generic/tclIOUtil.c (Tcl_GetCwd,NativeFileAttrStrings,
(Tcl_FSFileAttrStrings,Tcl_FSGetTranslatedStringPath,
(Tcl_FSGetNativePath):
* generic/tclIndexObj.c (Tcl_GetIndexFromObj,Tcl_GetIndexFromObjStruct):
More TIP 27 updates in tclIOUtil.c and tclIndexObj.c that were
overlooked before. [Patch 504671]
***POTENTIAL INCOMPATIBILITY***
Includes a source incompatibility in the tablePtr arguments of the
Tcl_GetIndexFromObj* routines.
* generic/tclDecls.h: make genstubs
* generic/tclBinary.c (Tcl_BinaryObjCmd):
* generic/tclClock.c (Tcl_ClockObjCmd):
* generic/tclCmdAH.c (Tcl_EncodingObjCmd, Tcl_FileObjCmd):
* generic/tclCmdIL.c (Tcl_InfoObjCmd,Tcl_LsearchObjCmd,Tcl_LsortObjCmd):
* generic/tclCmdMZ.c (Tcl_TraceObjCmd,Tcl_RegexpObjCmd,Tcl_RegsubObjCmd,
(Tcl_StringObjCmd,Tcl_SubstObjCmd,Tcl_SwitchObjCmd,
(TclTraceCommandObjCmd,TclTraceVariableObjCmd):
* generic/tclCompCmds.c (TclCompileStringCmd):
* generic/tclEvent.c (Tcl_UpdateObjCmd):
* generic/tclFileName.c (Tcl_GlobObjCmd):
* generic/tclIO.c (Tcl_FileEventObjCmd):
* generic/tclIOCmd.c (Tcl_SeekObjCmd,Tcl_ExecObjCmd,Tcl_SocketObjCmd,
(Tcl_FcopyObjCmd):
* generic/tclInterp.c (Tcl_InterpObjCmd,SlaveObjCmd):
* generic/tclNamesp.c (Tcl_NamespaceObjCmd):
* generic/tclPkg.c (Tcl_PackageObjCmd):
* generic/tclTest.c (Tcltest_Init,TestencodingObjCmd,TestgetplatformCmd,
(TestlocaleCmd,TestregexpObjCmd,TestsaveresultCmd,
(TestGetIndexFromObjStructObjCmd,TestReportFileAttrStrings):
* generic/tclTestObj.c (TestindexObjCmd,TeststringObjCmd):
* generic/tclTimer.c (Tcl_AfterObjCmd):
* generic/tclVar.c (Tcl_ArrayObjCmd):
* mac/tclMacFCmd.c (SetFileFinderAttributes):
* unix/tclUnixChan.c (TclpOpenFileChannel):
* unix/tclUnixFCmd.c (tclpFileAttrStrings):
* unix/tclUnixFile.c (TclpObjAccess,TclpObjChdir,TclpObjStat,
(TclpObjLstat):
* win/tclWinFCmd.c (tclpFileAttrStrings): Updated callers.
* doc/RegExp.3:
* doc/Utf.3:
* generic/tcl.decls:
* generic/tclInt.decls:
* generic/tclRegexp.c:
* generic/tclUtf.c: Updated APIs in generic/tclUtf.c and
generic/tclRegexp.c according to the guidelines of TIP 27.
[Patch 471509]
* generic/regc_locale.c (element,cclass):
* generic/tclCmdMZ.c (Tcl_StringObjCmd):
* generic/tclFileName.c (TclpGetNativePathType,SplitMacPath):
* generic/tclIO.c (ReadChars):
* mac/tclMacLoad.c (TclpLoadFile):
* win/tclWinFile.c (TclpGetUserHome): Updated callers.
* generic/tclDecls.h:
* generic/tclIntDecls.h: make genstubs
* doc/ParseCmd.3 (Tcl_ParseVar):
* generic/tcl.decls (Tcl_ParseVar):
* generic/tclParse.c (Tcl_ParseVar):
* generic/tclTest.c (TestparsevarObjCmd): Updated APIs in
generic/tclParse.c according to the guidelines of TIP 27. Updated
callers. [Patch 501046]
* generic/tclDecls.h: make genstubs
* generic/tcl.decls (Tcl_RecordAndEval):
* generic/tclDecls.h: make genstubs
* generic/tclHistory.c (Tcl_RecordAndEval): Updated APIs in
generic/tclHistory.c according to the guidelines of TIP 27.
[Patch 504091]
* doc/CrtSlave.3:
* generic/tcl.decls (Tcl_CreateAlias, Tcl_CreateAliasObj,
(Tcl_CreateSlave, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_GetSlave):
* generic/tclInterp.c (Tcl_CreateAlias, Tcl_CreateAliasObj,
(Tcl_CreateSlave, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_GetSlave):
Updated APIs in the file generic/tclInterp.c according to the
guidelines of TIP 27. [Patch 501371]
***POTENTIAL INCOMPATIBILITY***
Includes a source incompatibility in the targetCmdPtr arguments of
the Tcl_GetAlias* routines.
* generic/tclDecls.h: make genstubs
2002-01-15 Don Porter <dgp@users.sourceforge.net>
* doc/SetErrno.3 (Tcl_ErrnoMsg): Corrected documentation for
Tcl_ErrnoMsg; it takes an integer argument. Thanks to Georgios
Petasis. [Bug 468183]
* doc/AddErrInfo.3 (Tcl_PosixError):
* doc/Eval.3 (Tcl_EvalFile):
* doc/FileSystem.c (Tcl_FSOpenFileChannel,Tcl_FSOpenFileChannelProc):
* doc/OpenFileChnl.3 (Tcl_OpenFileChannel):
* doc/SetErrno.3 (Tcl_ErrnoId,Tcl_ErrnoMsg):
* doc/Signal.3 (Tcl_SignalId,Tcl_SignalMsg):
* generic/tcl.decls (Tcl_ErrnoId,TclErrnoMsg,Tcl_EvalFile,
(Tcl_OpenFileChannel,Tcl_PosixError,Tcl_SignalId,Tcl_SignalMsg,
(Tcl_FSOpenFileChannel):
* generic/tcl.h (Tcl_FSOpenFileChannelProc):
* generic/tclIO.c (FlushChannel):
* generic/tclIOUtil.c (Tcl_OpenFileChannel,Tcl_EvalFile,TclGetOpenMode,
(Tcl_PosixError,Tcl_FSOpenFileChannel):
* generic/tclInt.decls (TclGetOpenMode):
* generic/tclInt.h (TclOpenFileChannelProc_,TclGetOpenMode,
(TclpOpenFileChannel):
* generic/tclPipe.c (TclCleanupChildren):
* generic/tclPosixStr.c (Tcl_ErrnoId,Tcl_ErrnoMsg,Tcl_SignalId,
(Tcl_SignalMsg):
* generic.tclTest.c (PretendTclpOpenFileChannel,
(TestOpenFileChannelProc1,TestOpenFileChannelProc2,
(TestOpenFileChannelProc3,TestReportOpenFileChannel):
* mac/tclMacChan.c (TclpOpenFileChannel):
* unix/tclUnixChan.c (TclpOpenFileChannel):
* win/tclWinChan.c (TclpOpenFileChannel): Updated APIs in
generic/tclIOUtil.c and generic/tclPosixStr.c according to the
guidelines of TIP 27. Updated callers. [Patch 499196]
* generic/tclDecls.h:
* generic/tclIntDecls.h: make genstubs
* doc/CrtChannel.3:
* doc/OpenFileChnl.3:
* generic/tcl.decls:
* generic/tclIO.h:
* generic/tclIO.c (DoWrite, Tcl_RegisterChannel, Tcl_GetChannel,
(Tcl_CreateChannel, Tcl_GetChannelName, CloseChannel, Tcl_Write,
(Tcl_WriteRaw, Tcl_Ungets, Tcl_BadChannelOption, Tcl_GetChannelOption,
(Tcl_SetChannelOption, Tcl_GetChannelNamesEx, Tcl_ChannelName):
Updated APIs in the file generic/tclIO.c according to the guidelines
of TIP 27. Several minor documentation corrections as well. [Patch
503565]
* generic/tclDecls.h: make genstubs
* generic/tcl.h (Tcl_DriverOutputProc, Tcl_DriverGetOptionProc,
(Tcl_DriverSetOptionProc):
* generic/tclIOGT.c (TransformOutputProc, TransformGetOptionProc,
(TransformSetOptionProc):
* mac/tclMacChan.c (FileOutput, StdIOOutput):
* man/tclMacSock.c (TcpGetOptionProc, TcpOutput):
* unix/tclUnixChan.c (FileOutputProc, TcpGetOptionProc, TcpOutputProc,
(TtyGetOptionProc, TtySetOptionProc):
* unix/tclUnixPipe.c (PipeOuputProc):
* win/tclWinChan.c (FileOutputProc):
* win/tclWinConsole.c (ConsleOutputProc):
* win/tclWinPipe.c (PipeOuputProc):
* win/tclWinSerial.c (SerialOutputProc, SerialGetOptionProc,
(SerialSetOptionProc):
* win/tclWinSock.c (TcpGetOptionProc, TcpOutput): Updated channel
driver interface according to the guidelines of TIP 27. See also [Bug
500348].
* doc/CrtChannel.3:
* generic/tcl.h:
* generic/tclIO.c:
* generic/tclIO.h:
* generic/tclInt.h:
* tools/checkLibraryDoc.tcl:
Moved Tcl_EolTranslation enum declaration from generic/tcl.h to
generic/tclInt.h (renamed to TclEolTranslation). It is not used
anywhere in Tcl's public interface.
2002-01-14 Don Porter <dgp@users.sourceforge.net>
* doc/GetIndex.3:
* doc/WrongNumArgs.3:
* generic/tcl.decls (Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct,
(Tcl_WrongNumArgs):
* generic/tclIndexObj.c (Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct,
(Tcl_WrongNumArgs): Updated APIs in the file generic/tclIndexObj.c
according to the guidelines of TIP 27. [Patch 501491]
* generic/tclDecls.h: make genstubs
2002-01-11 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/configure.in:
* win/configure: Regen.
* win/configure.in: Use ${libdir} instead of ${exec_prefix}/lib
to properly support the --libdir option to configure. [Bug 489370]
2002-01-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* win/tclWinSerial.c (SerialSetOptionProc): Applied patch for [Bug
500348] supplied by Rolf Schroedter <schroedter@users.sf.net>. The
function modified the contents of the the 'value' string and now does
not do this anymore. This is a followup to the change made on
2001-12-17.
2002-01-11 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc: Removed -GD compiler option. It was intended for
future use, but MS is again changing the future at their whim. The
D4002 warning was harmless though, but someone using VC .NET logged it
as a concern. [Bug 501565]
2002-01-11 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in: Burn Tcl build directory into tcltest executable
to avoid crashes caused by ld loading a previously installed version
of the tcl shared library. [Bug 218110]
2002-01-10 Don Porter <dgp@users.sourceforge.net>,
Kevin Kenny <kennykb@users.sourceforge.net>
* unix/tclLoadDld.c (TclpLoadFile): syntax error: unbalanced parens.
Kevin notes that it's far from clear that this file is ever included
in an actual build; Linux without dlopen appears to be a nonexistent
configuration.
2002-01-08 Don Porter <dgp@users.sourceforge.net>,
Kevin Kenny <kennykb@users.sourceforge.net>
* doc/StaticPkg.3 (Tcl_StaticPackage):
* generic/tcl.decls (Tcl_StaticPackage):
* generic/tclDecls.h (Tcl_StaticPackage):
* generic/tclInt.decls (TclGuessPackageName):
* generic/tclInt.h (TclGuessPackageName):
* generic/tclLoad.c (Tcl_StaticPackage):
* generic/tclLoadNone.c (TclGuessPackageName):
* mac/tclMacLoad.c (TclGuessPackageName):
* unix/tclLoadAout.c (TclGuessPackageName):
* unix/tclLoadDl.c (TclGuessPackageName):
* unix/tclLoadDld.c (TclGuessPackageName):
* unix/tclLoadDyld.c (TclGuessPackageName):
* unix/tclLoadNext.c (TclGuessPackageName):
* unix/tclLoadOSF.c (TclGuessPackageName):
* unix/tclLoadShl.c (TclGuessPackageName):
* win/tclWinLoad.c (TclGuessPackageName): Updated APIs in the files
*/tcl*Load*.c according to the guidelines of TIP 27. [Patch 501096]
2002-01-09 Don Porter <dgp@users.sourceforge.net>
* generic/tclTest.c (MainLoop):
* tests/main.test (Tcl_Main-1.{3,4,5,6}): Corrected some non-portable
tests from the new Tcl_Main changes. Thanks to Kevin Kenny.
2002-01-07 Don Porter <dgp@users.sourceforge.net>
* generic/tclEvent.c (TclInExit):
* generic/tclIOUtil.c (SetFsPathFromAbsoluteNormalized,
(SetFsPathFromAny,Tcl_FSNewNativePath,DupFsPathInternalRep):
* generic/tclListObj.c (TclLsetList,TclLsetFlat): Added some type
casts to satisfy picky compilers.
* generic/tclMain.c: Bug fix: neglected the NULL case in
TclGetStartupScriptFileName(). Broke Tk/wish.
2002-01-05 Don Porter <dgp@users.sourceforge.net>
* doc/Tcl_Main.3:
* generic/tclMain.c: Substantial rewrite and expanded documentation
of Tcl_Main to correct a number of bugs and flaws:
* Interactive Tcl_Main can now enter a main loop, exit that
loop and continue interactive operations. The loop may even
exit in the midst of interactive command typing without loss
of the partial command. [Bugs 486453, 474131]
* Tcl_Main now gracefully handles deletion of its master
interpreter.
* Interactive Tcl_Main can now operate with non-blocking stdin
* Interactive Tcl_Main can now detect EOF on stdin even in
mid-command. [Bug 491341]
* Added VFS-aware internal routines for managing the startup
script selection.
* Tcl variable 'tcl_interactive' is now linked to C variable
'tty' so that one can disable/enable interactive prompts at
the script level when there is no startup script. This is
meant for use by the test suite.
* Consistent use of the Tcl libraries standard channels as
returned by Tcl_GetStdChannel(); as opposed to the channels
named 'stdin', 'stdout', and 'stderr' in the master interp,
which can be different or unavailable.
* Tcl_Main now calls Tcl_Exit() if evaluation of [exit] in the
master interpreter returns, assuring Tcl_Main does not
return.
* Documented Tcl_Main's absence from public stub table
* Documented that Tcl_Main does not return.
* Documented Tcl variables set by Tcl_Main.
* All prompts are done from a single procedure, Prompt.
* Use of Tcl_Obj-enabled interfaces everywhere.
* generic/tclInt.decls (TclGetStartupScriptPath,
(TclSetStartupScriptPath): New internal VFS-aware routines for
managing the startup script of Tcl_Main.
* generic/tclIntDecls.h:
* generic/tclStubInit.c: make genstubs
* generic/tclTest.c (TestsetmainloopCmd,TestexitmainloopCmd,
(Tcltest_Init,TestinterpdeleteCmd):
* tests/main.test (new): Added new file to test suite that thoroughly
tests generic/tclMain.c; added some new test commands for testing
Tcl_SetMainLoop().
2002-01-04 Don Porter <dgp@users.sourceforge.net>
* doc/Alloc.3:
* doc/Concat.3:
* doc/CrtMathFnc.3:
* doc/Hash.3:
* doc/Interp.3:
* doc/LinkVar.3:
* doc/ObjectType.3:
* doc/PkgRequire.3:
* doc/Preserve.3:
* doc/SetResult.3:
* doc/SplitList.3:
* doc/SplitPath.3:
* doc/TCL_MEM_DEBUG.3: Updated documentation to describe the ckalloc,
ckfree, ckrealloc, attemptckalloc, and attemptckrealloc macros, and to
accurately describe when and how they are used. [Bug 497459]
* generic/tclThreadJoin.c (TclRememberJoinableThread,TclJoinThread):
Replaced Tcl_Alloc and Tcl_Free calls with ckalloc and ckfree so that
memory debugging is supported.
2002-01-04 Daniel Steffen <das@users.sourceforge.net>
* mac/tclMacTime.c (TclpGetTZName): fix for daylight savings TZName
bug
2002-01-03 Don Porter <dgp@users.sourceforge.net>
* doc/FileSystem.3:
* generic/tclIOUtil.c: Updated some old uses of "fileName" to new VFS
terminology, "pathPtr".
2002-01-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/basic.test (basic-39.4): Greatly simplified test while still
leaving it so that it crashes when run without the fix to the
[foreach] implementation.
* generic/tclCmdAH.c (Tcl_ForeachObjCmd): Stopped [Bug 494348] from
happening by not trying to be so clever with cacheing; if nothing
untoward is happening anyway, the less efficient technique will only
add a few instruction cycles (one function call and a few
derefs/assigns per list per iteration, with no change in the number of
tests) and if something odd *is* going on, the code is now far more
robust.
* tests/basic.test (basic-39.4): Reproducable script from [Bug 494348]
2002-01-02 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/util.test (Wrapper_Tcl_StringMatch,util-5.*): Rewrote so the
test is performed with the right internal function since [string
match] no longer uses Tcl_StringCaseMatch internally.
* tests/string.test (string-11.51):
* generic/tclUtf.c (Tcl_UniCharCaseMatch):
* generic/tclUtil.c (Tcl_StringCaseMatch): Fault with matching
case-insensitive non-ASCII patterns containing upper case characters.
[Bug 233257]
******************************************************************
*** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" ***
*** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" ***
*** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" ***
******************************************************************
|
Changes to README.
1 | README: Tcl | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
README: Tcl
This is the Tcl 8.4.16 source distribution.
Tcl/Tk is also available through NetCVS:
http://tcl.sourceforge.net/
You can get any source release of Tcl from the file distributions
link at the above URL.
RCS: @(#) $Id: README,v 1.49.2.19 2007/05/30 14:05:17 dgp Exp $
Contents
--------
1. Introduction
2. Documentation
3. Compiling and installing Tcl
4. Development tools
|
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | http://www.tcl.tk/software/tcltk/8.4.html Detailed release notes can be found at the file distributions page by clicking on the relevant version. http://sourceforge.net/project/showfiles.php?group_id=10894 Information about Tcl itself can be found at | | | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | http://www.tcl.tk/software/tcltk/8.4.html Detailed release notes can be found at the file distributions page by clicking on the relevant version. http://sourceforge.net/project/showfiles.php?group_id=10894 Information about Tcl itself can be found at http://www.tcl.tk/about/ There have been many Tcl books on the market. Many are mentioned in the Wiki: http://wiki.tcl.tk/book 2a. Unix Documentation ---------------------- The "doc" subdirectory in this release contains a complete set of reference manual entries for Tcl. Files with extension ".1" are for programs (for example, tclsh.1); files with extension ".3" are for C |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | Windows help Tcl documentation will appear in the "Start" menu: Start | Programs | Tcl | Tcl Help 3. Compiling and installing Tcl ------------------------------- | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | Windows help Tcl documentation will appear in the "Start" menu: Start | Programs | Tcl | Tcl Help 3. Compiling and installing Tcl ------------------------------- There are brief notes in the unix/README, win/README, and macosx/README about compiling on these different platforms. There is additional information about building Tcl from sources at http://www.tcl.tk/doc/howto/compile.html 4. TclPro Development tools --------------------------- |
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
and/or Tk and made them freely available to the Tcl community. An archive
of these contributions is kept on the machine ftp://archives.tcl.tk/pub/tcl
(aka ftp://ftp.procplace.com/pub/tcl). You can access the archive using
anonymous FTP. The archive also contains several FAQ ("frequently asked
questions") documents that provide solutions to problems that are commonly
encountered by Tcl newcomers.
| | | | | | | | < | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
and/or Tk and made them freely available to the Tcl community. An archive
of these contributions is kept on the machine ftp://archives.tcl.tk/pub/tcl
(aka ftp://ftp.procplace.com/pub/tcl). You can access the archive using
anonymous FTP. The archive also contains several FAQ ("frequently asked
questions") documents that provide solutions to problems that are commonly
encountered by Tcl newcomers.
7. The Tcler's Wiki
-------------------
A Wiki-based open community site covering all aspects of Tcl/Tk is at:
http://wiki.tcl.tk/
A wealth of useful information can be found there.
8. Mailing lists
----------------
Several mailing lists are hosted at SourceForge to discuss development or
use issues (like Macintosh and Windows topics). For more information and
to subscribe, visit:
|
| ︙ | ︙ | |||
177 178 179 180 181 182 183 | difficult to make incompatible changes to Tcl/Tk at this point, due to the size of the installed base. The Tcl community is too large for us to provide much individual support for users. If you need help we suggest that you post questions to comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric questions for which no one else is likely to know the answer. In addition, | | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 | difficult to make incompatible changes to Tcl/Tk at this point, due to the size of the installed base. The Tcl community is too large for us to provide much individual support for users. If you need help we suggest that you post questions to comp.lang.tcl. We read the newsgroup and will attempt to answer esoteric questions for which no one else is likely to know the answer. In addition, see the following page on the Wiki for links to other organizations that offer Tcl/Tk training: http://wiki.tcl.tk/training 10. Thank You ------------- We'd like to express our thanks to the Tcl community for all the helpful suggestions, bug reports, and patches we have received. Tcl/Tk has improved vastly and will continue to do so with your help. |
Changes to changes.
1 2 | Recent user-visible changes to Tcl: | | | 1 2 3 4 5 6 7 8 9 10 | Recent user-visible changes to Tcl: RCS: @(#) $Id: changes,v 1.79.2.50 2007/05/16 22:13:07 das Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. 2. Semi-colon now available for grouping commands on a line. 3. For a command to span multiple lines, must now use backslash-return |
| ︙ | ︙ | |||
4214 4215 4216 4217 4218 4219 4220 | serial devices so that non-blocking channels do not block on partial input lines. (redman) 3/23/99 (bug fix) Added a new Tcl_ServiceModeHook interface. This is used on Windows to avoid the various problems that people have been seeing where the system hangs when tclsh is running outside of the event loop. As part of this, renamed | | | 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 | serial devices so that non-blocking channels do not block on partial input lines. (redman) 3/23/99 (bug fix) Added a new Tcl_ServiceModeHook interface. This is used on Windows to avoid the various problems that people have been seeing where the system hangs when tclsh is running outside of the event loop. As part of this, renamed TcapAlertNotifier back to Tcl_AlertNotifier since it is public. (stanton) 3/23/99 (feature change) Test suite now uses "tcltest" namespace to define the test procedure and other auxiliary procedures as well as global variables. The previously chosen "test" namespace was thought to be too generic and likely to create conflits. (hirschl) |
| ︙ | ︙ | |||
5753 5754 5755 5756 5757 5758 5759 |
2003-02-25 (feature change) [pkg_mkIndex -load]: case-insensitive match
*** POTENTIAL INCOMPATIBILITY ***
2003-02-27 (bug fix)[694232] stop [lsearch -start 0 {} x] segfault
--- Released 8.4.2, March 3, 2003 --- See ChangeLog for details ---
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 |
2003-02-25 (feature change) [pkg_mkIndex -load]: case-insensitive match
*** POTENTIAL INCOMPATIBILITY ***
2003-02-27 (bug fix)[694232] stop [lsearch -start 0 {} x] segfault
--- Released 8.4.2, March 3, 2003 --- See ChangeLog for details ---
2003-03-06 (bug fix)[699042] Correct case-insensitive unicode string
comparison in Tcl_UniCharNcasecmp
2003-03-11 (bug fix) Corrected loading of tclpip8x.dll on Win9x
2003-03-12 (bug fix)[702383] Corrected parsing of interp create --
2003-03-12 (bug fix)[685106] Correct Tcl_SubstObj handling of \x00 bytes
2003-03-14 (bug fix)[702622 699060] Correct wide int issues in 'format'
2003-03-14 (bug fix)[698146] Remove assumption that file times and longs
are the same size.
2003-03-18 (bug fix)[697862] Allow Tcl to differentiate between reparse
points which are symlinks and mounted drives on Windows
2003-03-19 (bug fix)[705406] Bad command count on TCL_OUT_LINE_COMPILE
2003-03-20 (bug fix)[707174] Store pointers to notifier funcs in a struct
to work around some platform linker issues
2003-03-22 (bug fix)[708218] Load correct (non-)debug dll for dde or
registry
2003-03-24 (bug fix)[631741 696893] Fixing ObjMakeUpvar's lookup algorithm
for the created local variable
2003-04-07 (bug fix)[713562] Make sure that tclWideIntType is defined and
somewhat sensible everywhere
2003-04-07 (bug fix)[711371] Corrected string limits of arguments
interpolated in error messages for 'if'
2003-04-11 (bug fix)[718878] Corrected inconsistent results of
[string is integer] observed on systems where sizeof(long) != sizeof(int)
2003-04-12 (bug fix) Substantial changes to the Windows clock synch
phase-locked loop in a quest for improved loop stability
2003-04-16 [713562] Made changes so that the "wideInt" Tcl_ObjType is
defined on all platforms, even those where TCL_WIDE_INT_IS_LONG is defined.
Also made the Tcl_Value struct have a wideValue field on all platforms.
Potential incompatibility for TCL_WIDE_INT_IS_LONG platforms because that
struct changes size.
*** POTENTIAL INCOMPATIBILITY ***
2003-04-25 (bug fix)[727271] Catch any errors returned by the Windows
functions handling TLS ASAP instead of waiting to get some mysterious crash
later on due to bogus pointers.
2003-04-29 (bug fix) Correct 'glob -path {[tcl]} *', where leading
special character instead lists files in '/'. Bug only occurs on Windows
where '\' is also a directory separator.
2003-05-09 (bug fix)[731754] Fixed memory leak in threaded allocator on
Windows caused by treating cachePtr as a TLS index
2003-05-10 (bug fix)[710642] Ensure cd is thread-safe
2003-05-10 (bug fix)[718002] Correct mem leak on closing a Windows serial
port
2003-05-10 (bug fix)[714106] Prevent string repeat crash when overflow
sizes were given (throws error).
2003-05-13 (feature enhancement)[736774] Use new versioned bundle resource
API to get tcl runtime library for TCL_VERSION on Mac OS X.
2003-05-13 (bug fix)[711232] Worked around the issue of realpath() not
being thread-safe on Mac OS X by defining NO_REALPATH for threaded builds
on Mac OS X.
2003-05-14 (bug fix)[557030] Correct handling of the gb2312 encoding by
making it an alias of the euc-cn encoding and creating a gb2312-raw
encoding for the original. Most uses of gb2312 really mean euc-cn.
2003-05-14 (bug fix)[736421] Corrected another putenv() copy behavior
problem when compiling on Windows and using Microsoft's runtime.
--- Released 8.4.3, May 20, 2003 --- See ChangeLog for details ---
2003-05-23 (bug fix)[726018] reverted internals change to the
'cmdName' Tcl_ObjType that broke several extensions (TclBlend, e4graph...)
in the 8.4.3 release.
2003-06-10 (bug fix)[495830] stop eval of bytecode in deleted interp.
2003-06-17 (bug fix) corrections to regexp when matching emtpy string.
2003-06-25 (bug fix)[748957] -*ieee compiler flags for Tru64 builds.
2003-07-11 (bug fix) [pkg_mkIndex] indexes provided packages, not indexed ones.
2003-07-15 (feature enhancement) MacOSX build system rewrite.
2003-07-15 (bug fix)[771613] corrected segfault in [if] (buffer overflow)
2003-07-16 (bug fix)[756791] corrected assumption that Tcl_Free == free
2003-07-16 (feature enhancement) -DTCL_UTF_MAX=6 compile option forces
internal UCS-4 representation of Unicode (default is recommended UCS-2).
2003-07-16 (bug fix)[767578] 64-bit corrections in thread notifier.
2003-07-16 (bug fix)[759607] Safe Base tests normalized paths.
2003-07-16 (feature enhancement)[Patch 679315] improved Cygwin path support
2003-07-18 (bug fix)[706359] corrected broken -output option of [tcltest::test]
=> tcltest 2.4.4
2003-07-18 (bug fix)[753315] MT-safety of VFS records.
2003-07-18 (bug fix)[759888] support for user:pass in URL by [http::geturl]
=> http 2.4.4
Improved documentation, new tests, and some code cleanup.
[655300, 720634, 735364, 748700, 756112, 756744, 756951, 758488, 760768,
763312, 769895, 771539, 771840, 771947, 771949, 772333]
--- Released 8.4.4, July 22, 2003 --- See ChangeLog for details ---
2003-07-23 (bug fix)[775976] fix registry compilation for VC7.
2003-08-05 (enhancement)[781585] Use Tcl_ResetResult in bytecodes to
prevent potential costly Tcl_Obj duplication.
2003-08-06 (bug fix)[781609] prevent non-Windows platforms from trying to
use the registry package inside msgcat.
2003-08-27 (bug fix)[411825] Fix TclNeedSpace to handle non-breaking space
(\u00A0) and backslash escapes correctly.
2003-09-01 (bug fix)[788780] Fix thread-safety issues in filesystem records.
2003-09-19 (bug fix)[804681] Protect ::errorInfo and ::errorCode traces
from corrupting stack.
2003-09-23 (bug fix)[218871] Fix handling of glob-sensitive chars in
auto_load and auto_import.
2003-10-03 (bug fix)[811483] Fixed refcount management for command and
execution traces.
2003-10-04 (bug fix)[789040] Fixed exec command.com error for Win9x.
2003-10-06 (bug fix)[767834, 813273] Fixed volumerelative file
normalization and 'file join' inconsistencies.
2003-10-08 (bug fix)[769812] Fix Tcl_NumUtfChars string length calculation
when negative parameter is given.
2003-10-22 (bug fix)[800106] Handle VFS mountpoints inside glob'd dirs.
2003-10-22 (bug fix)[599468] Watch for FD_CLOSE too on Windows when
asked for writable events by the generic layer.
2003-10-23 (bug fix)[813606] Detect OS X pipes correctly.
2003-11-05 (bug fix)[832657] Allow .. in libpath initialization.
2003-11-11 (bug fix) Improve AIX-64 build configuration.
2003-11-17 (bug fix)[230589, 504785, 505048, 703709, 840258] fixes to
various odd regexp "can't happen" bugs.
--- Released 8.4.5, November 20, 2003 --- See ChangeLog for details ---
2003-12-02 (bug fix)[851747] object sharing fix in [binary scan]
2003-12-09 (platform support)[852369] update errno usage for recent glibc
2003-12-12 (bug fix)[858937] fix for [file normalize ~nobody]
2003-12-17 (bug fix)[839519] fixed two memory leaks (vasiljevic)
2004-01-09 (bug fix)[873311] fixed infinite loop in TclFinalizeFilesystem
2004-02-02 (bug fix)[405995] Tcl_Ungets buffer filling fix
2004-02-04 (bug fix)[833910] tcltest command line option parsing error
=> tcltest 2.4.5
2004-02-04 (bug fix)[833637] code error in tcltest -preservecore operation
2004-02-12 (feature enhancement) update HP-11 build libs setup
2004-02-17 (bug fix)[849514,859251] corrected [file normailze] of $link/..
2004-02-17 (bug fix)[772288] Unix std channels forced to exist at startup.
2004-02-17 (new default) tcltest::configure -verbose {body error}
2004-02-19 (bug fix) init.tcl search path with unusual --libdir (samson)
2004-02-25 (bug fix)[554068] stopped broken [exec] quoting of { (gravereaux)
2004-02-25 (bug fix)[888777] plugged memory leak with long host names (cassoff)
2004-03-01 (bug fix)[462580] corrected level interpretation of Tcl_CreateTrace
2004-03-01 (platform support)[218561] Allow 64-bit configure on IRIX64-6.5*
--- Released 8.4.6, March 1, 2004 --- See ChangeLog for details ---
2004-03-08 (bug fix)[910525] [glob -path] in root directory (darley)
2004-03-15 (bug fix)[916795] syntax error -> compiler segfault (sofer,porter)
2004-03-29 (bug fix)[920667] install into any Unicode path on Win (hobbs)
2004-03-31 (bug fix)[811457] support translation to "" (porter)
2004-03-31 (bug fix)[811461] ignore locales with no "language" part (porter)
=> msgcat 1.3.2
2004-04-07 (platform support) properly substitute more values in Windows
tclConfig.sh (hobbs)
2004-04-23 (bug fix)[930851] reset channel EOF when eofchar changes (kupries)
2004-05-03 (bug fix)[947070] stack overflow prevention on Win (kenny)
2004-05-03 (bug fix)[868853] fix leak in [fconfigure $serial -xchar] (cassoff)
2004-04-05 (bug fix)[928353,929892,928808,947440,948177] test fixes: OSX
(abner)
2004-05-04 (bug fix) crash: [cd] w/ volumerelative $HOME (hobbs)
2004-05-05 (bug fix)[794839] socket connect error -> r/w fileevents
(gravereaux)
2004-05-14 (bug fix)[940278,922848] [clock] notices $::env(TZ) changes,
gmt works on all platforms. (kenny, welton, glessner)
2004-05-18 (bug fix)[500285,500389,852944] [clock %G %V] ISO8601 week numbers
(kenny)
2004-05-22 (bug fix)[735335,736729] variable name resolution error (sofer)
2004-05-24 (bug fix) support for non-WIDE_INT aware math functions (hobbs)
2004-05-25 (new feature) [http::config -urlencoding] (hobbs)
=> http 2.5.0
2004-05-26 (bug fix)[960926] file count doubled when -singleproc 1 (porter)
=> tcltest 2.2.6
2004-05-27 (bug fix)[949905] corrected utf-8 encoding of \u0000 on I/O (max)
2004-06-05 (bug fix)[976722] hi-res clock fixes: Win
(godfrey, suchenwirth, kenny)
2004-06-10 (bug fix)[932314] bad return values from Tcl_FSChdir() (vasiljevic)
2004-06-14 (bug fix) correct dde hangs w/non-responsive apps (thoyts)
=> dde 1.2.3
2004-06-21 (platform support) exceptions w/ gcc -O3 on Win (dejong)
2004-06-29 (bug fix)[981733] SafeBase global pollution (fellows)
2004-07-02 (new feature)[TIP 202] pipe redirection 2>@1 (hobbs)
2004-07-03 (bug fix)[908375] round() wide integer support (lavana, sofer)
2004-07-15 (bug fix)[770053] crash in thread finalize of notifier (vasiljevic)
2004-07-15 (bug fix)[990453] plug mutex leaks on reinit
(mistachkin, vasiljevic)
2004-07-16 (bug fix)[990500] clean exit of notifier thread
(mistachkin, kupries)
2004-07-19 (bug fix)[987967] improved self-init of mutexes on Win (vasiljevic)
2004-07-19 (bug fix)[874058] improved build configuration on 64-bit systems.
Corrects Tcl_StatBuf definition issues. (hobbs)
2004-07-20 (bug fix) pure Darwin/CFLite support (steffen)
2004-07-20 (bug fix)[736426] plug leaky allocator reinit (mistachkin, kenny)
--- Released 8.4.7, July 26, 2004 --- See ChangeLog for details ---
2004-07-28 (bug fix)[999084] no deadlock in re-entrant Tcl_Finalize (porter)
2004-08-10 (bug fix) thread IDs on 64-bit systems (ratcliff,vasiljevic)
2004-08-13 (bug fix) avoid malicious code acceptance by [mclocale] (porter)
=> msgcat 1.3.3
2004-08-16 (bug fix)[1008314] Tcl_SetVar TCL_LIST_ELEMENT (sofer,porter)
2004-08-19 (bug fix)[1011860] [scan %ld] fix on LP64 (fellows,porter)
2004-08-30 (bug fix) [string map $x $x] crash (fellows)
2004-09-01 (bug fix)[1020445] WIN64 support (hobbs)
2004-09-07 (bug fix)[1016167] [after] overwrites its imports (kenny)
2004-09-08 (bug fix) fixed [clock format 0 -format %k] (kenny)
2004-09-09 (bug fix)[560297] fixed broken [namespace forget] logic (porter)
2004-09-09 (bug fix)[1017299] fixed [namespace import] cycle prevention (porter)
2004-09-10 (performance) $x[set x {}] is now fast [K $x [set x {}]] (sofer)
2004-09-10 (bug fix)[868489] better control over int <-> wideInt (fellows,kenny)
2004-09-10 (bug fix)[1025359] POSIX errorCode from wide seeks (kupries,fellows)
2004-09-18 (bug fix)[868467] fix [expr 5>>32] => 0, not 5 (hintermayer,fellows)
2004-09-23 (bug fix)[1016726] fix `make clean` in static config (leitgeb,dejong)
2004-09-29 (bug fix)[1036649] syntax error in [subst] => buffer overflow (sofer)
2004-09-30 (bug fix)[1038021] save/restore error state: var traces (porter)
2004-10-08 (bug fix)[954263] case insensitive [file exec] for Win (hobbs,darley)
2004-10-14 (performance) [info commands/globals/procs/vars $pattern] faster
when $pattern is trivial (fellows)
2004-10-28 (bug fix)[1030548] restore the --enable-symbols --enable-threads
build on Win (mistachkin,kenny,kupries)
2004-10-29 (bug fix)[1055673] fix command line syntax error message (porter)
=> tcltest 2.2.7
2004-10-31 (bug fix)[1057461] fix [info globals ::varName] (fellows)
2004-11-02 (bug fix)[761471] fix [expr {NaN == NaN}] (sofer)
2004-11-02 (bug fix)[1017151] misleading errorInfo after tests (seeger,porter)
2004-11-11 (bug fix)[1034337] recursive file delete, MacOSX (steffen)
2004-11-12 (bug fix)[1004065] stop crash when TCL_UTF_MAX==6 (hobbs,porter)
2004-11-15 (bug fix)[10653678] [trace variable],[trace remove] interop (porter)
2004-11-16 (bug fix)[695441] [tcl_findLibrary] search $::auto_path too (porter)
2004-11-16 (bug fix)[1067709] crash in [fconfigure -ttycontrol] (hobbs)
2004-11-18 (new feature) configure options --enable-man-suffix (max)
Documentation improvements [759545,1058446,1062647,1065732,etc.]
Test suite expansion [1036649,1001997,etc.]
--- Released 8.4.8, November 18, 2004 --- See ChangeLog for details ---
2004-11-22 (bug fix)[1030465] Improve HAVE_TYPE_OFF64_T check (dejong)
2004-11-23 (bug fix)[1072654] Fixed segfault in info vars trivial
matching branch (new in 8.4.8) (porter)
2004-11-23 (bug fix)[1043129] Fixed the treatment of backslashes in file
join on Windows (darley)
2004-11-24 (bug fix)[1001325, 1071701] Fixed readdir_r detection and usage
(dejong, kenny, porter)
2004-11-24 (bug fix)[1071807] Fixed all uses of 'select' to use standard
macros rather than older bit-whacking style (kenny)
2004-11-26 (bug fix)[1072136] Remove file normalize on tcl_findLibrary
search path uniqification added in 8.4.8 (porter)
2004-12-02 (bug fix)[1074671] Ensure tilde paths are not returned specially
by 'glob' (darley)
--- Released 8.4.9, December 6, 2004 --- See ChangeLog for details ---
2004-12-29 (platform support)[1092952,1091967] MSVC7, gcc OPT compiles (hobbs)
2005-01-05 (bug fix)[1084595] encoding maps for some Chinese locales (fellows)
2005-01-06 (performance)[1020491] [http::mapReply] (fellows)
=> http 2.5.1
2005-01-25 (bug fix)[1101670] [auto_reset] update for [namespace] (porter)
2005-01-27 (new feature)[TIP 218] Tcl_Channel API update for threads (kupries)
2005-01-27 (bug fix)[1109484] Tcl_Expr* updates for Tcl_WideInt (hobbs)
2005-01-28 (platform support)[1021871] Solaris gcc 64-bit support (hobbs)
2005-02-10 (bug fix)[1119369] Tcl_EvalObjEx: avoid shimmer loss of List intrep
(sofer,macdonald)
2005-02-10 (platform support) correct gcc builds for AIX-4+, HP-UX-11 (hobbs)
2005-02-24 (bug fix)[1119798] prevent [source $directory] (porter,mpettigr)
=> tcltest 2.2.8
2005-03-10 (bug fix)[1153871] bad ClientData cast (porter,victorovich)
2005-03-15 (platform support) OpenBSD ports patch (thoyts)
2005-03-15 (platform support)[1163422] time_t wider than long (kenny)
2005-03-18 (bug fix)[1115904] restore recursion limit in direct eval (porter)
2005-03-29 (platform support) allow msys builds without cygwin (hobbs)
2005-04-06 (bug fix)[1178445] fix memory waste at thread exit (vasiljevic)
2005-04-13 (bug fix) min buffer size dropped from 10 to 1 byte (gravereaux)
2005-04-19 (bug fix)[947693] Windows pipes honor -blocking during close
(gravereaux) ***POTENTIAL INCOMPATIBILITY***
async pipes on windows, set -blocking 1 before [close] to receive exit status
2005-04-20 (bug fix)[1090869] Tcl_GetInt accept 0x80000000, 64-bit
(porter,singh)
2005-04-22 (bug fix)[1187123] [string is boolean] respect EIAS (porter)
2005-04-25 (platform support) builds on Mac OS X 10.1 (steffen)
2005-05-06 (platform support) x86_64 Solarix cc and Solaris 10 builds (hobbs)
2005-05-14 (platform support) Mac OSX: configurable CoreFoundation API
(steffen)
2005-05-14 (platform support) Mac OSX: use realpath when threadsafe (steffen)
2005-05-20 (bug fix)[1201589] boolean literal prefix in expressions (porter)
2005-05-24 (platform support) Darwin build support merged into unix (steffen)
2005-05-24 (new feature)[1202209] Mac OSX: support [load] of .bundle binaries
Can support [load] from memory as well (steffen)
2005-05-24 (new feature)[1202178] [time] returns non-integer result (steffen)
2005-05-31 (bug fix)[1082283] Unix: notifier thread now joinable (vasiljevic)
Documentation improvements [1075433,1085127,1117017,1124160,1149605,etc.]
--- Released 8.4.10, June 4, 2005 --- See ChangeLog for details ---
2005-06-06 (bug fix)[1213678] Windows/gcc: crash in stack.test (kenny)
2005-06-07 (bug fix) Unix: --enable-threads compile failure (fellows)
2005-06-18 (bug fix)[1154163] [format %h] on 64-bit OS's (kraft,fellows)
2005-06-21 (bug fix)[1201035,1224585] execution trace crashes (porter)
2005-06-21 (bug fix)[1194458] Windows: [file split] (kenny,porter)
2005-06-22 (bug fix)[1225727] Windows: pipe finalization crash (kenny)
2005-06-22 (bug fix)[1225571] Windows: [file pathtype] buffer overflow (thoyts)
2005-06-22 (bug fix)[1225044] Windows: UMR in pipe close (kenny)
2005-06-23 (bug fix)[1225957] Windows/gcc: crashes in assembler code (kenny)
2005-06-27 (revert)[1101670] [auto_reset] disabled in non-global namespace.
Restores Tcl 8.4.9 behavior (porter)
--- Released 8.4.11, June 28, 2005 --- See ChangeLog for details ---
2005-07-01 (bug fix)[1222872] notifier spurious wake-up protection (vasiljevic)
2005-07-05 (bug fix)[1077262] improved Tcl_Encoding lifetimes (porter)
2005-07-05 (bug fix)[1230597] allow idempotent [namespace import] (porter)
2005-07-07 (bug fix)[1095909] readdir_r usage purged (hobbs)
2005-07-22 (enhancement)[1237755] 8.4 features in script library (fradin,porter)
2005-07-24 (new feature) configure macros SC_PROG_TCLSH, SC_BUILD_TCLSH (dejong)
2005-07-26 (bug fix)[1047286] cmd delete traces during namespace delete (porter)
2005-07-26 (new unix feature)[1231015] ${prefix}/share on ::tcl_pkgPath (dejong)
2005-07-28 (unix bug fix)[1245953] O_APPEND for >> redirection (fellows)
2005-07-29 (bug fix)[1247135] [info globals] return only existing vars (fellows)
2005-07-30 (new Darwin feature) TCL_LOAD_FROM_MEMORY configuration (steffen)
2005-08-05 (bug fix)[1241572] correct [expr abs($LONG_MIN)] (kenny)
2005-08-05 (Solaris bug fix)[1252475] recognize cp1251 encoding (wagner,fellows)
2005-08-17 (bug fix)[1217375] [file mkdir] race (diekhans,darley)
2005-08-25 (bug fix)[1267380] [lrepeat] buffer overflow prevention (fellows)
2005-08-29 (bug fix)[1275043] restore round() away from zero (kenny)
2005-09-07 (bug fix)[1283976] invalid [format %c -1] result (porter)
2005-09-15 (RHEL bug fix)[1287638] support open >2GB files RHEL 3 (palan)
2005-09-30 (bug fix)[1306162] $argv encoding and list formatting (porter)
2005-10-04 (bug fix)[1067708] [fconfigure -ttycontrol] leak (hobbs)
2005-10-04 (bug fix)[1182373] [http::mapReply] update to RFC 3986 (aho,hobbs)
=> http 2.5.2
2005-10-04 (HPUX bug fix)[1204237] shl_load() and DYNAMIC_PATH (collins,hobbs)
2005-10-05 (bug fix)[979640] buffer overrun mixing putenv(), ::env (bold,hobbs)
2005-10-13 (bug fix)[1284178] [format] accept all integer values (porter)
2005-10-22 (bug fix)[1251791] optimization exposed wide/int difference(sofer)
2005-10-23 (bug fix)[1334947] value refcount error in var setting (sofer)
2005-11-01 (bug fix)[1337941] Tcl_TraceCommand() -> crash (devilliers,porter)
2005-11-03 (new Win NT/XP feature) Unicode console support (kovalenko,thoyts)
2005-11-03 (bug fix)[1201171] [encoding system] in Tclkit (schekin,porter)
2005-11-04 (bug fix)[1337229,1338280] [namespace delete] / unset traces (porter)
2005-11-04 (enhancement) Korean timezone abbreviations (kenny)
2005-11-04 (bug fix)[1317477] double encoding of time zone (kenny)
2005-11-04 (Win enhancement)[1267871] extended exit codes (newman,thoyts)
2005-11-04 (platform support)[1163896] LynxOS [load] (heidibr)
2005-11-08 (bug fix)[1348775] unset trace memory leak (sofer)
2005-11-08 (bug fix)[1162286] [package ifneeded] warns reported (lavana,porter)
*** POTENTIAL INCOMPATIBILITY ***
2005-11-09 (bug fix)[1350293] [after $negative $script] fixed (kenny)
2005-11-15 (Win bug fix)[926016,1353840] correct [file mtime] (kenny)
2005-11-18 (bug fix)[1358369] URL parsing standards compliance (wu,fellows)
2005-11-18 (bug fix)[1359094] Tclkit crash (thoyts, kupries)
2005-11-18 (bug fix)[1355942,1355342] cmd delete trace/ namespace delete (sofer)
2005-11-20 (bug fix)[1091431] Tcl_InitStubs failure crashes wish (english)
2005-11-29 (bug fix)[1366683] [lsearch -regexp] backrefs (cleverly,fellows)
2005-11-29 (enhancement)[1369597] Win 64: --enable-64bit=amd64|ia64 (hobbs)
2005-12-05 (Darwin bug fix)[1034337] NFS recursive file delete (steffen)
--- Released 8.4.12, December 3, 2005 --- See ChangeLog for details ---
2005-12-09 (bug fix)[1374778] [lsearch -start $pastEnd] => -1 (fellows)
2005-12-12 (bug fix)[1241572] correct [expr abs($LONG_MIN)] again (max)
2005-12-12 (bug fix)[1377619] configure syntax error exposed in bash-3.1 (hobbs)
2006-01-09 (bug fix)[1400572] [info level $l] => "namespace inscope" (porter)
2006-01-23 (bug fix)[1410553] Tcl_GetRange Unicode confusion (twylite,spjuth)
2006-03-06 (bug fix)[1439836,1444291] fix TCL_EVAL_{GLOBAL,INVOKE} handling
when auto-loading or exec traces are present (porter)
2006-03-10 (bug fix)[1437595] Win socket finalize with threads (vasiljevic)
2005-03-13 (revert 2005-07-26 change) ${prefix}/share on ::tcl_pkgPath (porter)
2006-03-14 (bug fix)[1381436,859820] threadsafe Tcl_WaitPid (gravereaux,kupries)
2006-03-14 (bug fix)[768659] pipeline error when last command missing (kupries)
2006-03-18 (bug fix)[1193497] Win porting of [file writable] (darley,vogel)
2006-03-28 (bug fix)[1064247] BSD: path normalization with realpath() (steffen)
2006-03-28 (revert 2005-11-03 feature) Unicode console support (hobbs)
*** POTENTIAL INCOMPATIBILITY ***
2006-04-03 (bug fix)[1462248] crash reading utf-8 chars spanning multiple
buffers at end of file (kraft,kupries)
2006-04-04 (revert 2005-11-08)[1162286] [package ifneeded] warns (porter)
*** POTENTIAL INCOMPATIBILITY ***
2006-04-05 (bug fix)[1464039] Tcl_GetIndexFromObj: empty key (fellows)
2006-04-05 (bug fix) overdue dde, registry patchelevel increments (porter)
=> dde 1.2.4
=> registry 1.1.4
2006-04-06 (bug fix)[1457515] TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
removed (steffen)
2006-04-11 (bug fix)[1458266] enter/enterstep trace interference (leunissen)
--- Released 8.4.13, April 19, 2006 --- See ChangeLog for details ---
2006-05-04 (bug fix)[1480509] srand() accept wide input (porter,afredd)
2006-05-05 (bug fix)[1481986] interactive Tcl_Main blocks main loop (porter,lin)
2006-05-13 (bug fix)[1482718] proc re-compile: preserve the previous
bytecode while references still on the stack (porter,ryazanov)
2006-05-13 (bug fix)[943995] fixed [glob] on VFS (porter)
2006-05-27 (bug fix)[923072] Darwin: made unthreaded CoreFoundation notifier
naked-fork safe on Tiger (steffen)
2006-05-31 (revert 2006-01-09)[1400572] namespace inscope & info level (porter)
*** POTENTIAL INCOMPATIBILITY ***
2006-06-14 (platform support)[1424909] MS VS2005 support (thoyts)
2006-07-20 (platform support) Mac OS X weak linking (steffen)
2006-07-20 (bug fix) Darwin: execve() works iff event loop not yet run (steffen)
2006-08-18 (bug fix) intermittent failures in TclUnixWaitForFile() (steffen)
2006-08-18 (platform support) Darwin x86_64 (steffen)
2006-08-21 (bug fix)[1457797] Darwin 64-bit notifier hang (steffen)
2006-08-21 (bug fix) Darwin: recursively called event loop (steffen)
2006-08-30 (bug fix)[1548263] filesystem segfaults (hobbs,mccormack)
2006-09-06 (bug fix)[999544] use of MT-safe system calls (vasiljevic)
2006-09-10 (platform support) Darwin: msgcat use CFLocale (steffen)
=> msgcat 1.3.4
2006-09-22 (bug fix)[1562528] NULL terminates variadic calls (fellows,ryazanov)
2006-09-26 (platform support) MSVC8 AMD64 support (thoyts)
2006-10-05 (bug fix)[1570718] make [lappend $nonList] complain (sofer,virden)
2006-10-05 (bug fix)[1122671] alignment fixes in unicode encoding routines
(hobbs,staplin)
2006-10-05 (new feature) [set ::http::strict 1] (default value is 0) to enable
URL validity checking against RFC 2986 (hobbs)
=> http 2.5.3
--- Released 8.4.14, October 19, 2006 --- See ChangeLog for details ---
2006-10-31 (platform support)[1582769] Fix build with VC2003 (thoyts)
2006-11-07 (bug fix)[1586470] [file copy] on afs (kupries,dionizio)
2006-11-26 (platform support)[1230558] --enable-64bit on more systems (steffen)
2006-11-27 (bug fix)[1602208] use > 32 async sockets on 64bit system (fontaine)
2007-01-25 (configure change) ensure CPPFLAGS env var used when set (steffen)
2007-01-30 (enhancement) new target: `install-private-headers` (hobbs, steffen)
2007-02-12 (bug fix)[1516109] escape encodings crossing chan buffers (dejong)
2007-03-01 (bug fix)[1671138] compiled [foreach {} x {}] hangs (fellows)
2007-03-10 (bug fix)[1675116] list shimmer crash in [lsort] (fellows)
2007-03-13 (bug fix)[1671087] list shimmer crash in [foreach] (porter)
2007-03-13 (bug fix)[1669489] list shimmer crash in [array set] (porter)
2007-03-17 (bug fix)[1682211] buffer overflow in [registry keys] (kenny)
=> registry 1.1.5
2007-04-29 (bug fix) fts_open() crash on 64bit Darwin 8 or earlier (steffen)
--- Released 8.4.15, May 25, 2007 --- See ChangeLog for details ---
|
Changes to compat/memcmp.c.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
int
memcmp(s1, s2, n)
CONST VOID *s1; /* First string. */
CONST VOID *s2; /* Second string. */
size_t n; /* Length to compare. */
{
| | > | | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
int
memcmp(s1, s2, n)
CONST VOID *s1; /* First string. */
CONST VOID *s2; /* Second string. */
size_t n; /* Length to compare. */
{
CONST unsigned char *ptr1 = (CONST unsigned char *) s1;
CONST unsigned char *ptr2 = (CONST unsigned char *) s2;
for ( ; n-- ; ptr1++, ptr2++) {
unsigned char u1 = *s1, u2 = *s2;
if ( u1 != u2) {
return (u1-u2);
}
}
return 0;
}
|
Changes to compat/strftime.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * strftime.c -- * * This file contains a modified version of the BSD 4.4 strftime * function. * * This file is a modified version of the strftime.c file from the BSD 4.4 * source. See the copyright notice below for details on redistribution * restrictions. The "license.terms" file does not apply to this file. * * Changes 2002 Copyright (c) 2002 ActiveState Corporation. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * strftime.c -- * * This file contains a modified version of the BSD 4.4 strftime * function. * * This file is a modified version of the strftime.c file from the BSD 4.4 * source. See the copyright notice below for details on redistribution * restrictions. The "license.terms" file does not apply to this file. * * Changes 2002 Copyright (c) 2002 ActiveState Corporation. * * RCS: @(#) $Id: strftime.c,v 1.10.2.3 2005/11/04 18:18:04 kennykb Exp $ */ /* * Copyright (c) 1989 The Regents of the University of California. * All rights reserved. * * Redistribution and use in source and binary forms, with or without |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ #if defined(LIBC_SCCS) | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF * SUCH DAMAGE. */ #if defined(LIBC_SCCS) static char *rcsid = "$Id: strftime.c,v 1.10.2.3 2005/11/04 18:18:04 kennykb Exp $"; #endif /* LIBC_SCCS */ #include <time.h> #include <string.h> #include <locale.h> #include "tclInt.h" #include "tclPort.h" |
| ︙ | ︙ | |||
109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
static size_t gsize;
static char *pt;
static int _add _ANSI_ARGS_((const char* str));
static int _conv _ANSI_ARGS_((int n, int digits, int pad));
static int _secs _ANSI_ARGS_((const struct tm *t));
static size_t _fmt _ANSI_ARGS_((const char *format,
const struct tm *t));
size_t
TclpStrftime(s, maxsize, format, t, useGMT)
char *s;
size_t maxsize;
const char *format;
const struct tm *t;
| > | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
static size_t gsize;
static char *pt;
static int _add _ANSI_ARGS_((const char* str));
static int _conv _ANSI_ARGS_((int n, int digits, int pad));
static int _secs _ANSI_ARGS_((const struct tm *t));
static size_t _fmt _ANSI_ARGS_((const char *format,
const struct tm *t));
static int ISO8601Week _ANSI_ARGS_((CONST struct tm* t, int *year ));
size_t
TclpStrftime(s, maxsize, format, t, useGMT)
char *s;
size_t maxsize;
const char *format;
const struct tm *t;
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 232 233 234 235 236 237 238 | if (!_conv(t->tm_mday, 2, '0')) return(0); continue; case 'e': if (!_conv(t->tm_mday, 2, ' ')) return(0); continue; case 'H': if (!_conv(t->tm_hour, 2, '0')) return(0); continue; case 'I': if (!_conv(t->tm_hour % 12 ? t->tm_hour % 12 : 12, 2, '0')) | > > > > > > > > > > > > > > > > > > | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
if (!_conv(t->tm_mday, 2, '0'))
return(0);
continue;
case 'e':
if (!_conv(t->tm_mday, 2, ' '))
return(0);
continue;
case 'g':
{
int year;
ISO8601Week( t, &year );
if ( !_conv( year%100, 2, '0' ) ) {
return( 0 );
}
continue;
}
case 'G':
{
int year;
ISO8601Week( t, &year );
if ( !_conv( year, 4, '0' ) ) {
return( 0 );
}
continue;
}
case 'H':
if (!_conv(t->tm_hour, 2, '0'))
return(0);
continue;
case 'I':
if (!_conv(t->tm_hour % 12 ?
t->tm_hour % 12 : 12, 2, '0'))
|
| ︙ | ︙ | |||
297 298 299 300 301 302 303 |
continue;
case 'u':
if (!_conv(t->tm_wday ? t->tm_wday : 7, 1, '0'))
return(0);
continue;
case 'V':
{
| < < < < < < < | < < < < < < < < < < < | > | > | | > | > | > | > | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
continue;
case 'u':
if (!_conv(t->tm_wday ? t->tm_wday : 7, 1, '0'))
return(0);
continue;
case 'V':
{
int week = ISO8601Week( t, NULL );
if (!_conv(week, 2, '0'))
return(0);
continue;
}
case 'W':
if (!_conv(MON_WEEK(t), 2, '0'))
return(0);
continue;
case 'w':
if (!_conv(t->tm_wday, 1, '0'))
return(0);
continue;
#ifdef WIN32
/*
* To properly handle the localized time routines on Windows,
* we must make use of the special localized calls.
*/
case 'c':
if (!GetDateFormat(LOCALE_USER_DEFAULT,
DATE_LONGDATE | LOCALE_USE_CP_ACP,
&syst, NULL, buf, BUF_SIZ)
|| !_add(buf)
|| !_add(" ")) {
return(0);
}
/*
* %c is created with LONGDATE + " " + TIME on Windows,
* so continue to %X case here.
*/
case 'X':
if (!GetTimeFormat(LOCALE_USER_DEFAULT,
LOCALE_USE_CP_ACP,
&syst, NULL, buf, BUF_SIZ)
|| !_add(buf)) {
return(0);
}
continue;
case 'x':
if (!GetDateFormat(LOCALE_USER_DEFAULT,
DATE_SHORTDATE | LOCALE_USE_CP_ACP,
&syst, NULL, buf, BUF_SIZ)
|| !_add(buf)) {
return(0);
}
continue;
#else
case 'c':
if (!_fmt(_CurrentTimeLocale->d_t_fmt, t))
return(0);
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 |
continue;
case 'Y':
if (!_conv((t->tm_year + TM_YEAR_BASE), 4, '0'))
return(0);
continue;
case 'Z': {
char *name = (isGMT ? "GMT" : TclpGetTZName(t->tm_isdst));
| > | > | < > | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
continue;
case 'Y':
if (!_conv((t->tm_year + TM_YEAR_BASE), 4, '0'))
return(0);
continue;
case 'Z': {
char *name = (isGMT ? "GMT" : TclpGetTZName(t->tm_isdst));
int wrote;
Tcl_UtfToExternal(NULL, NULL, name, -1, 0, NULL,
pt, gsize, NULL, &wrote, NULL);
pt += wrote;
gsize -= wrote;
continue;
}
case '%':
/*
* X311J/88-090 (4.12.3.5): if conversion char is
* undefined, behavior is undefined. Print out the
* character itself as printf(3) does.
|
| ︙ | ︙ | |||
427 428 429 430 431 432 433 |
_conv(n, digits, pad)
int n, digits;
int pad;
{
static char buf[10];
register char *p;
| > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
_conv(n, digits, pad)
int n, digits;
int pad;
{
static char buf[10];
register char *p;
p = buf + sizeof( buf ) - 1;
*p-- = '\0';
if ( n == 0 ) {
*p-- = '0'; --digits;
} else {
for (; n > 0 && p > buf; n /= 10, --digits)
*p-- = (char)(n % 10 + '0');
}
while (p > buf && digits-- > 0)
*p-- = (char) pad;
return(_add(++p));
}
static int
_add(str)
const char *str;
{
for (;; ++pt, --gsize) {
if (!gsize)
return(0);
if (!(*pt = *str++))
return(1);
}
}
static int
ISO8601Week( t, year )
CONST struct tm* t;
int* year;
{
/* Find the day-of-year of the Thursday in
* the week in question. */
int ydayThursday;
int week;
if ( t->tm_wday == 0 ) {
ydayThursday = t->tm_yday - 3;
} else {
ydayThursday = t->tm_yday - t->tm_wday + 4;
}
if ( ydayThursday < 0 ) {
/* This is the last week of the previous year. */
if ( IsLeapYear(( t->tm_year + TM_YEAR_BASE - 1 )) ) {
ydayThursday += 366;
} else {
ydayThursday += 365;
}
week = ydayThursday / 7 + 1;
if ( year != NULL ) {
*year = t->tm_year + 1899;
}
} else if ( ( IsLeapYear(( t -> tm_year + TM_YEAR_BASE ))
&& ydayThursday >= 366 )
|| ( !IsLeapYear(( t -> tm_year
+ TM_YEAR_BASE ))
&& ydayThursday >= 365 ) ) {
/* This is week 1 of the following year */
week = 1;
if ( year != NULL ) {
*year = t->tm_year + 1901;
}
} else {
week = ydayThursday / 7 + 1;
if ( year != NULL ) {
*year = t->tm_year + 1900;
}
}
return week;
}
|
Changes to compat/string.h.
1 2 3 4 5 6 7 8 9 10 11 | /* * string.h -- * * Declarations of ANSI C library procedures for string handling. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | /* * string.h -- * * Declarations of ANSI C library procedures for string handling. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: string.h,v 1.4.18.1 2005/04/26 00:46:02 das Exp $ */ #ifndef _STRING #define _STRING #include <tcl.h> /* * The following #include is needed to define size_t. (This used to * include sys/stdtypes.h but that doesn't exist on older versions * of SunOS, e.g. 4.0.2, so I'm trying sys/types.h now.... hopefully * it exists everywhere) */ #ifndef MAC_TCL #include <sys/types.h> #endif #ifdef __APPLE__ extern VOID * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); #else extern char * memchr _ANSI_ARGS_((CONST VOID *s, int c, size_t n)); #endif extern int memcmp _ANSI_ARGS_((CONST VOID *s1, CONST VOID *s2, size_t n)); extern char * memcpy _ANSI_ARGS_((VOID *t, CONST VOID *f, size_t n)); #ifdef NO_MEMMOVE #define memmove(d, s, n) bcopy ((s), (d), (n)) #else extern char * memmove _ANSI_ARGS_((VOID *t, CONST VOID *f, |
| ︙ | ︙ |
Changes to compat/strstr.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * strstr.c -- * * Source code for the "strstr" library routine. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | /* * strstr.c -- * * Source code for the "strstr" library routine. * * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: strstr.c,v 1.3.2.1 2005/04/12 18:28:56 kennykb Exp $ */ #include <tcl.h> #ifndef NULL #define NULL 0 #endif /* *---------------------------------------------------------------------- * * strstr -- * * Locate the first instance of a substring in a string. |
| ︙ | ︙ |
Changes to doc/AddErrInfo.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: AddErrInfo.3,v 1.8.2.1 2003/07/18 16:56:24 dgp Exp $ '\" .so man.macros .TH Tcl_AddErrorInfo 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AddObjErrorInfo, Tcl_AddErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_PosixError, Tcl_LogCommandInfo \- record information about errors .SH SYNOPSIS |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | An argument list which must have been initialized using \fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. .AP "CONST char" *script in Pointer to first character in script containing command (must be <= command) .AP "CONST char" *command in Pointer to first character in command that generated the error .AP int commandLength in | | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | An argument list which must have been initialized using \fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. .AP "CONST char" *script in Pointer to first character in script containing command (must be <= command) .AP "CONST char" *command in Pointer to first character in command that generated the error .AP int commandLength in Number of bytes in command; -1 means use all bytes up to first null byte .BE .SH DESCRIPTION .PP These procedures are used to manipulate two Tcl global variables that hold information about errors. The variable \fBerrorInfo\fR holds a stack trace of the |
| ︙ | ︙ |
Changes to doc/AppInit.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: AppInit.3,v 1.3.24.1 2006/07/30 16:18:41 jenglish Exp $ '\" .so man.macros .TH Tcl_AppInit 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AppInit \- perform application-specific initialization .SH SYNOPSIS |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | the main programs for Tcl applications such as \fBtclsh\fR and \fBwish\fR. Its purpose is to allow new Tcl applications to be created without modifying the main programs provided as part of Tcl and Tk. To create a new application you write a new version of \fBTcl_AppInit\fR to replace the default version provided by Tcl, then link your new \fBTcl_AppInit\fR with the Tcl library. .PP | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | the main programs for Tcl applications such as \fBtclsh\fR and \fBwish\fR. Its purpose is to allow new Tcl applications to be created without modifying the main programs provided as part of Tcl and Tk. To create a new application you write a new version of \fBTcl_AppInit\fR to replace the default version provided by Tcl, then link your new \fBTcl_AppInit\fR with the Tcl library. .PP \fBTcl_AppInit\fR is invoked by \fBTcl_Main\fR and \fBTk_Main\fR after their own initialization and before entering the main loop to process commands. Here are some examples of things that \fBTcl_AppInit\fR might do: .IP [1] Call initialization procedures for various packages used by the application. Each initialization procedure adds new commands to \fIinterp\fR |
| ︙ | ︙ |
Changes to doc/Async.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Async.3,v 1.5.18.1 2004/12/09 09:24:54 dkf Exp $ '\" .so man.macros .TH Tcl_AsyncCreate 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_AsyncCreate, Tcl_AsyncMark, Tcl_AsyncInvoke, Tcl_AsyncDelete, Tcl_AsyncReady \- handle asynchronous events .SH SYNOPSIS |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | allocation could have been in progress when the event occurred. The only safe approach is to set a flag indicating that the event occurred, then handle the event later when the world has returned to a clean state, such as after the current Tcl command completes. .PP \fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR are thread sensitive. They access and/or set a thread-specific data | | | | | | | | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
allocation could have been in progress when the event occurred.
The only safe approach is to set a flag indicating that the event
occurred, then handle the event later when the world has returned
to a clean state, such as after the current Tcl command completes.
.PP
\fBTcl_AsyncCreate\fR, \fBTcl_AsyncDelete\fR, and \fBTcl_AsyncReady\fR
are thread sensitive. They access and/or set a thread-specific data
structure in the event of a core built with \fI\-\-enable\-threads\fR. The token
created by \fBTcl_AsyncCreate\fR contains the needed thread information it
was called from so that calling \fBTcl_AsyncMark\fR(\fItoken\fR) will only yield
the origin thread into the asynchronous handler.
.PP
\fBTcl_AsyncCreate\fR creates an asynchronous handler and returns
a token for it.
The asynchronous handler must be created before
any occurrences of the asynchronous event that it is intended
to handle (it is not safe to create a handler at the time of
an event).
When an asynchronous event occurs the code that detects the event
(such as a signal handler) should call \fBTcl_AsyncMark\fR with the
token for the handler.
\fBTcl_AsyncMark\fR will mark the handler as ready to execute, but it
will not invoke the handler immediately.
Tcl will call the \fIproc\fR associated with the handler later, when
the world is in a safe state, and \fIproc\fR can then carry out
the actions associated with the asynchronous event.
\fIProc\fR should have arguments and result that match the
type \fBTcl_AsyncProc\fR:
.CS
typedef int Tcl_AsyncProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIcode\fR);
.CE
The \fIclientData\fR will be the same as the \fIclientData\fR
argument passed to \fBTcl_AsyncCreate\fR when the handler was
created.
If \fIproc\fR is invoked just after a command has completed
execution in an interpreter, then \fIinterp\fR will identify
the interpreter in which the command was evaluated and
|
| ︙ | ︙ |
Changes to doc/ChnlStack.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1999-2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1999-2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: ChnlStack.3,v 1.4.4.1 2004/07/16 20:10:58 andreas_kupries Exp $ .so man.macros .TH Tcl_StackChannel 3 8.3 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_StackChannel, Tcl_UnstackChannel, Tcl_GetStackedChannel, Tcl_GetTopChannel \- stack an I/O channel on top of another, and undo it .SH SYNOPSIS |
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | .sp Tcl_Channel \fBTcl_GetTopChannel\fR(\fIchannel\fR) .sp .SH ARGUMENTS .AS Tcl_ChannelType .AP Tcl_Interp *interp in | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | .sp Tcl_Channel \fBTcl_GetTopChannel\fR(\fIchannel\fR) .sp .SH ARGUMENTS .AS Tcl_ChannelType .AP Tcl_Interp *interp in Interpreter for error reporting. .AP Tcl_ChannelType *typePtr in The new channel I/O procedures to use for \fIchannel\fP. .AP ClientData clientData in Arbitrary one-word value to pass to channel I/O procedures. .AP int mask in Conditions under which \fIchannel\fR will be used: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. |
| ︙ | ︙ |
Changes to doc/CrtChannel.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" Copyright (c) 1997-2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" Copyright (c) 1997-2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: CrtChannel.3,v 1.16.2.5 2005/10/05 20:35:45 andreas_kupries Exp $ .so man.macros .TH Tcl_CreateChannel 3 8.4 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_CreateChannel, Tcl_GetChannelInstanceData, Tcl_GetChannelType, Tcl_GetChannelName, Tcl_GetChannelHandle, Tcl_GetChannelMode, Tcl_GetChannelBufferSize, Tcl_SetChannelBufferSize, Tcl_NotifyChannel, Tcl_BadChannelOption, Tcl_ChannelName, Tcl_ChannelVersion, Tcl_ChannelBlockModeProc, Tcl_ChannelCloseProc, Tcl_ChannelClose2Proc, Tcl_ChannelInputProc, Tcl_ChannelOutputProc, Tcl_ChannelSeekProc, Tcl_ChannelWideSeekProc, Tcl_ChannelSetOptionProc, Tcl_ChannelGetOptionProc, Tcl_ChannelWatchProc, Tcl_ChannelGetHandleProc, Tcl_ChannelFlushProc, Tcl_ChannelHandlerProc, Tcl_ChannelThreadActionProc, Tcl_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Channel \fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) .sp |
| ︙ | ︙ | |||
32 33 34 35 36 37 38 39 40 41 42 43 44 45 | \fBTcl_GetChannelHandle\fR(\fIchannel, direction, handlePtr\fR) .sp .VS 8.4 Tcl_ThreadId \fBTcl_GetChannelThread\fR(\fIchannel\fR) .VE 8.4 .sp int \fBTcl_GetChannelBufferSize\fR(\fIchannel\fR) .sp \fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR) .sp \fBTcl_NotifyChannel\fR(\fIchannel, mask\fR) .sp | > > > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | \fBTcl_GetChannelHandle\fR(\fIchannel, direction, handlePtr\fR) .sp .VS 8.4 Tcl_ThreadId \fBTcl_GetChannelThread\fR(\fIchannel\fR) .VE 8.4 .sp int \fBTcl_GetChannelMode\fR(\fIchannel\fR) .sp int \fBTcl_GetChannelBufferSize\fR(\fIchannel\fR) .sp \fBTcl_SetChannelBufferSize\fR(\fIchannel, size\fR) .sp \fBTcl_NotifyChannel\fR(\fIchannel, mask\fR) .sp |
| ︙ | ︙ | |||
92 93 94 95 96 97 98 99 100 101 102 103 104 105 | .sp Tcl_DriverSeekProc * \fBTcl_ChannelSeekProc\fR(\fItypePtr\fR) .sp .VS 8.4 Tcl_DriverWideSeekProc * \fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR) .VE 8.4 .sp Tcl_DriverSetOptionProc * \fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR) .sp Tcl_DriverGetOptionProc * \fBTcl_ChannelGetOptionProc\fR(\fItypePtr\fR) | > > > | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | .sp Tcl_DriverSeekProc * \fBTcl_ChannelSeekProc\fR(\fItypePtr\fR) .sp .VS 8.4 Tcl_DriverWideSeekProc * \fBTcl_ChannelWideSeekProc\fR(\fItypePtr\fR) .sp Tcl_DriverThreadActionProc * \fBTcl_ChannelThreadActionProc\fR(\fItypePtr\fR) .VE 8.4 .sp Tcl_DriverSetOptionProc * \fBTcl_ChannelSetOptionProc\fR(\fItypePtr\fR) .sp Tcl_DriverGetOptionProc * \fBTcl_ChannelGetOptionProc\fR(\fItypePtr\fR) |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | \fBTcl_GetChannelHandle\fR places the OS-specific device handle associated with \fIchannel\fR for the given \fIdirection\fR in the location specified by \fIhandlePtr\fR and returns \fBTCL_OK\fR. If the channel does not have a device handle for the specified direction, then \fBTCL_ERROR\fR is returned instead. Different channel drivers will return different types of handle. Refer to the manual entries for each driver to determine what type of handle is returned. | < > | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 | \fBTcl_GetChannelHandle\fR places the OS-specific device handle associated with \fIchannel\fR for the given \fIdirection\fR in the location specified by \fIhandlePtr\fR and returns \fBTCL_OK\fR. If the channel does not have a device handle for the specified direction, then \fBTCL_ERROR\fR is returned instead. Different channel drivers will return different types of handle. Refer to the manual entries for each driver to determine what type of handle is returned. .PP .VS 8.4 \fBTcl_GetChannelThread\fR returns the id of the thread currently managing the specified \fIchannel\fR. This allows channel drivers to send their file events to the correct event queue even for a multi-threaded core. .VE 8.4 .PP \fBTcl_GetChannelMode\fR returns an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR, indicating whether the channel is open for input |
| ︙ | ︙ | |||
282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 | name is registered in the (thread)-global list of all channels (result == 1) or not (result == 0). .PP \fBTcl_CutChannel\fR removes the specified \fIchannel\fR from the (thread)global list of all channels (of the current thread). Application to a channel still registered in some interpreter is not allowed. .PP \fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the (thread)global list of all channels (of the current thread). Application to a channel registered in some interpreter is not allowed. .PP \fBTcl_ClearChannelHandlers\fR removes all channelhandlers and event scripts associated with the specified \fIchannel\fR, thus shutting down all event processing for this channel. .VE 8.4 .SH TCL_CHANNELTYPE | > > > > > > > > > > | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | name is registered in the (thread)-global list of all channels (result == 1) or not (result == 0). .PP \fBTcl_CutChannel\fR removes the specified \fIchannel\fR from the (thread)global list of all channels (of the current thread). Application to a channel still registered in some interpreter is not allowed. .VS 8.4 Also notifies the driver if the \fBTcl_ChannelType\fR version is \fBTCL_CHANNEL_VERSION_4\fR (or higher), and \fBTcl_DriverThreadActionProc\fR is defined for it. .VE 8.4 .PP \fBTcl_SpliceChannel\fR adds the specified \fIchannel\fR to the (thread)global list of all channels (of the current thread). Application to a channel registered in some interpreter is not allowed. .VS 8.4 Also notifies the driver if the \fBTcl_ChannelType\fR version is \fBTCL_CHANNEL_VERSION_4\fR (or higher), and \fBTcl_DriverThreadActionProc\fR is defined for it. .VE 8.4 .PP \fBTcl_ClearChannelHandlers\fR removes all channelhandlers and event scripts associated with the specified \fIchannel\fR, thus shutting down all event processing for this channel. .VE 8.4 .SH TCL_CHANNELTYPE |
| ︙ | ︙ | |||
319 320 321 322 323 324 325 326 327 328 | Tcl_DriverWatchProc *\fIwatchProc\fR; Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; Tcl_DriverClose2Proc *\fIclose2Proc\fR; Tcl_DriverBlockModeProc *\fIblockModeProc\fR; Tcl_DriverFlushProc *\fIflushProc\fR; Tcl_DriverHandlerProc *\fIhandlerProc\fR; Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; } Tcl_ChannelType; .CE .PP | > | > | | > | | | | > | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 | Tcl_DriverWatchProc *\fIwatchProc\fR; Tcl_DriverGetHandleProc *\fIgetHandleProc\fR; Tcl_DriverClose2Proc *\fIclose2Proc\fR; Tcl_DriverBlockModeProc *\fIblockModeProc\fR; Tcl_DriverFlushProc *\fIflushProc\fR; Tcl_DriverHandlerProc *\fIhandlerProc\fR; Tcl_DriverWideSeekProc *\fIwideSeekProc\fR; Tcl_DriverThreadActionProc *\fIthreadActionProc\fR; } Tcl_ChannelType; .CE .PP It is not necessary to provide implementations for all channel operations. Those which are not necessary may be set to NULL in the struct: \fIblockModeProc\fR, \fIseekProc\fR, \fIsetOptionProc\fR, \fIgetOptionProc\fR, and \fIclose2Proc\fR, in addition to \fIflushProc\fR, \fIhandlerProc\fR, and \fIthreadActionProc\fR. Other functions that cannot be implemented in a meaningful way should return \fBEINVAL\fR when called, to indicate that the operations they represent are not available. Also note that \fIwideSeekProc\fR can be NULL if \fIseekProc\fR is. .PP The user should only use the above structure for \fBTcl_ChannelType\fR instantiation. When referencing fields in a \fBTcl_ChannelType\fR structure, the following functions should be used to obtain the values: \fBTcl_ChannelName\fR, \fBTcl_ChannelVersion\fR, \fBTcl_ChannelBlockModeProc\fR, \fBTcl_ChannelCloseProc\fR, \fBTcl_ChannelClose2Proc\fR, \fBTcl_ChannelInputProc\fR, \fBTcl_ChannelOutputProc\fR, \fBTcl_ChannelSeekProc\fR, .VS 8.4 \fBTcl_ChannelWideSeekProc\fR, \fBTcl_ChannelThreadActionProc\fR, .VE 8.4 \fBTcl_ChannelSetOptionProc\fR, \fBTcl_ChannelGetOptionProc\fR, \fBTcl_ChannelWatchProc\fR, \fBTcl_ChannelGetHandleProc\fR, \fBTcl_ChannelFlushProc\fR, or \fBTcl_ChannelHandlerProc\fR. .PP The change to the structures was made in such a way that standard channel types are binary compatible. However, channel types that use stacked |
| ︙ | ︙ | |||
360 361 362 363 364 365 366 | \fBfile\fR or \fBsocket\fR. .PP This value can be retrieved with \fBTcl_ChannelName\fR, which returns a pointer to the string. .SH VERSION .PP | > | > > > > > | > > > | | | | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 | \fBfile\fR or \fBsocket\fR. .PP This value can be retrieved with \fBTcl_ChannelName\fR, which returns a pointer to the string. .SH VERSION .PP The \fIversion\fR field should be set to the version of the structure that you require. \fBTCL_CHANNEL_VERSION_2\fR is the minimum recommended. .VS 8.4 \fBTCL_CHANNEL_VERSION_3\fR must be set to specifiy the \fIwideSeekProc\fR member. .VE 8.4 .VS 8.4 \fBTCL_CHANNEL_VERSION_4\fR must be set to specifiy the \fIthreadActionProc\fR member (includes \fIwideSeekProc\fR). .VE 8.4 If it is not set to any of these, then this \fBTcl_ChannelType\fR is assumed to have the original structure. See \fBOLD CHANNEL TYPES\fR for more details. While Tcl will recognize and function with either structures, stacked channels must be of at least \fBTCL_CHANNEL_VERSION_2\fR to function correctly. .PP This value can be retrieved with \fBTcl_ChannelVersion\fR, which returns .VS 8.4 one of \fBTCL_CHANNEL_VERSION_4\fR, \fBTCL_CHANNEL_VERSION_3\fR, .VE 8.4 \fBTCL_CHANNEL_VERSION_2\fR, or \fBTCL_CHANNEL_VERSION_1\fR. .SH BLOCKMODEPROC .PP The \fIblockModeProc\fR field contains the address of a function called by the generic layer to set blocking and nonblocking mode on the device. \fIBlockModeProc\fR should match the following prototype: .PP |
| ︙ | ︙ | |||
401 402 403 404 405 406 407 408 409 410 411 412 413 414 | nonblocking mode and to implement the blocking or nonblocking behavior. For some device types, the blocking and nonblocking behavior can be implemented by the underlying operating system; for other device types, the behavior must be emulated in the channel driver. .PP This value can be retrieved with \fBTcl_ChannelBlockModeProc\fR, which returns a pointer to the function. .SH "CLOSEPROC AND CLOSE2PROC" .PP The \fIcloseProc\fR field contains the address of a function called by the generic layer to clean up driver-related information when the channel is closed. \fICloseProc\fR must match the following prototype: .PP | > > > > > > > > | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | nonblocking mode and to implement the blocking or nonblocking behavior. For some device types, the blocking and nonblocking behavior can be implemented by the underlying operating system; for other device types, the behavior must be emulated in the channel driver. .PP This value can be retrieved with \fBTcl_ChannelBlockModeProc\fR, which returns a pointer to the function. .PP A channel driver \fBnot\fR supplying a \fIblockModeProc\fR has to be very, very careful. It has to tell the generic layer exactly which blocking mode is acceptable to it, and should this also document for the user so that the blocking mode of the channel is not changed to an inacceptable value. Any confusion here may lead the interpreter into a (spurious and difficult to find) deadlock. .SH "CLOSEPROC AND CLOSE2PROC" .PP The \fIcloseProc\fR field contains the address of a function called by the generic layer to clean up driver-related information when the channel is closed. \fICloseProc\fR must match the following prototype: .PP |
| ︙ | ︙ | |||
774 775 776 777 778 779 780 781 782 783 784 785 786 787 | \fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR when this channel was created. The \fIinterestMask\fR is an OR-ed combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what type of event occurred on this channel. .PP This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns a pointer to the function. .SH TCL_BADCHANNELOPTION .PP This procedure generates a "bad option" error message in an (optional) interpreter. It is used by channel drivers when a invalid Set/Get option is requested. Its purpose is to concatenate the generic options list to the specific ones and factorize | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
\fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR
when this channel was created. The \fIinterestMask\fR is an OR-ed
combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what
type of event occurred on this channel.
.PP
This value can be retrieved with \fBTcl_ChannelHandlerProc\fR, which returns
a pointer to the function.
.VS 8.4
.SH "THREADACTIONPROC"
.PP
The \fIthreadActionProc\fR field contains the address of the function
called by the generic layer when a channel is created, closed, or
going to move to a different thread, i.e. whenever thread-specific
driver state might have to initialized or updated. It can be NULL.
The action \fITCL_CHANNEL_THREAD_REMOVE\fR is used to notify the
driver that it should update or remove any thread-specific data it
might be maintaining for the channel.
.PP
The action \fITCL_CHANNEL_THREAD_INSERT\fR is used to notify the
driver that it should update or initialize any thread-specific data it
might be maintaining using the calling thread as the associate. See
\fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail.
.PP
.CS
typedef void Tcl_DriverThreadActionProc(
ClientData \fIinstanceData\fR,
int \fIaction\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created.
.PP
These values can be retrieved with \fBTcl_ChannelThreadActionProc\fR,
which returns a pointer to the function.
.VE 8.4
.SH TCL_BADCHANNELOPTION
.PP
This procedure generates a "bad option" error message in an
(optional) interpreter. It is used by channel drivers when
a invalid Set/Get option is requested. Its purpose is to concatenate
the generic options list to the specific ones and factorize
|
| ︙ | ︙ |
Changes to doc/CrtCommand.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: CrtCommand.3,v 1.5.2.1 2004/07/16 20:46:52 andreas_kupries Exp $ '\" .so man.macros .TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateCommand \- implement new commands in C .SH SYNOPSIS |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 105 106 107 108 109 110 111 | the first \fIargc\fR values point to the argument strings, and the last value is NULL. .VS Note that the argument strings should not be modified as they may point to constant strings or may be shared with other parts of the interpreter. .VE .PP \fIProc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set the interpreter result to point to a string value; in the case of a \fBTCL_OK\fR return code this gives the result | > > > > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | the first \fIargc\fR values point to the argument strings, and the last value is NULL. .VS Note that the argument strings should not be modified as they may point to constant strings or may be shared with other parts of the interpreter. .VE .PP .VS Note that the argument strings are encoded in normalized UTF-8 since version 8.1 of Tcl. .VE .PP \fIProc\fR must return an integer code that is either \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR. See the Tcl overview man page for details on what these codes mean. Most normal commands will only return \fBTCL_OK\fR or \fBTCL_ERROR\fR. In addition, \fIproc\fR must set the interpreter result to point to a string value; in the case of a \fBTCL_OK\fR return code this gives the result |
| ︙ | ︙ |
Changes to doc/CrtMathFnc.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: CrtMathFnc.3,v 1.5.14.2 2003/04/16 22:26:16 dkf Exp $ '\" .so man.macros .TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions .SH SYNOPSIS |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | .AP Tcl_MathProc *proc in Procedure that implements the function. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR when it is invoked. .AP int *numArgsPtr out Points to a variable that will be set to contain the number of arguments to the function. | | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | .AP Tcl_MathProc *proc in Procedure that implements the function. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR when it is invoked. .AP int *numArgsPtr out Points to a variable that will be set to contain the number of arguments to the function. .AP Tcl_ValueType **argTypesPtr out Points to a variable that will be set to contain a pointer to an array giving the permissible types for each argument to the function which will need to be freed up using \fITcl_Free\fR. .AP Tcl_MathProc **procPtr out Points to a variable that will be set to contain a pointer to the implementation code for the function (or NULL if the function is implemented directly in bytecode.) .AP ClientData *clientDataPtr out Points to a variable that will be set to contain the clientData argument passed to \fITcl_CreateMathFunc\fR when the function was created if the function is not implemented directly in bytecode. |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR. \fBTcl_CreateMathFunc\fR allows applications to add additional functions to those already provided by Tcl or to replace existing functions. \fIName\fR is the name of the function as it will appear in expressions. If \fIname\fR doesn't already exist as a function then a new function is created. If it does exist, then the existing function is replaced. \fINumArgs\fR and \fIargTypes\fR describe the arguments to the function. | | > > | > > > > | > | > > > | | > > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR.
\fBTcl_CreateMathFunc\fR allows applications to add additional functions
to those already provided by Tcl or to replace existing functions.
\fIName\fR is the name of the function as it will appear in expressions.
If \fIname\fR doesn't already exist as a function then a new function
is created. If it does exist, then the existing function is replaced.
\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function.
Each entry in the \fIargTypes\fR array must be
.VS 8.4
one of TCL_INT, TCL_DOUBLE, TCL_WIDE_INT,
or TCL_EITHER to indicate whether the corresponding argument must be an
integer, a double-precision floating value, a wide (64-bit) integer,
or any, respectively.
.VE 8.4
.PP
Whenever the function is invoked in an expression Tcl will invoke
\fIproc\fR. \fIProc\fR should have arguments and result that match
the type \fBTcl_MathProc\fR:
.CS
typedef int Tcl_MathProc(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
Tcl_Value *\fIargs\fR,
Tcl_Value *\fIresultPtr\fR);
.CE
.PP
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR.
\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures,
which describe the actual arguments to the function:
.VS 8.4
.CS
typedef struct Tcl_Value {
Tcl_ValueType \fItype\fR;
long \fIintValue\fR;
double \fIdoubleValue\fR;
Tcl_WideInt \fIwideValue\fR;
} Tcl_Value;
.CE
.PP
The \fItype\fR field indicates the type of the argument and is
one of TCL_INT, TCL_DOUBLE or TCL_WIDE_INT.
.VE 8.4
It will match the \fIargTypes\fR value specified for the function unless
the \fIargTypes\fR value was TCL_EITHER. Tcl converts
the argument supplied in the expression to the type requested in
\fIargTypes\fR, if that is necessary.
Depending on the value of the \fItype\fR field, the \fIintValue\fR,
.VS 8.4
\fIdoubleValue\fR or \fIwideValue\fR
.VE 8.4
field will contain the actual value of the argument.
.PP
\fIProc\fR should compute its result and store it either as an integer
in \fIresultPtr->intValue\fR or as a floating value in
\fIresultPtr->doubleValue\fR.
It should set also \fIresultPtr->type\fR to one of
.VS 8.4
TCL_INT, TCL_DOUBLE or TCL_WIDE_INT
.VE 8.4
to indicate which value was set.
Under normal circumstances \fIproc\fR should return TCL_OK.
If an error occurs while executing the function, \fIproc\fR should
return TCL_ERROR and leave an error message in the interpreter's result.
.PP
.VS 8.4
\fBTcl_GetMathFuncInfo\fR retrieves the values associated with
|
| ︙ | ︙ |
Changes to doc/CrtObjCmd.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: CrtObjCmd.3,v 1.7.2.1 2004/05/05 20:54:47 dkf Exp $ '\" .so man.macros .TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_DeleteCommandFromToken, Tcl_GetCommandInfo, Tcl_GetCommandInfoFromToken, Tcl_SetCommandInfo, Tcl_SetCommandInfoFromToken, Tcl_GetCommandName, Tcl_GetCommandFullName, Tcl_GetCommandFromObj \- implement new commands in C .SH SYNOPSIS |
| ︙ | ︙ | |||
271 272 273 274 275 276 277 | Note that \fBTcl_SetCommandInfo\fR and \fBTcl_SetCommandInfoFromToken\fR both allow the ClientData for a command's deletion procedure to be given a different value than the ClientData for its command procedure. .PP Note that neither \fBTcl_SetCommandInfo\fR nor \fBTcl_SetCommandInfoFromToken\fR will change a command's namespace. | | | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | Note that \fBTcl_SetCommandInfo\fR and \fBTcl_SetCommandInfoFromToken\fR both allow the ClientData for a command's deletion procedure to be given a different value than the ClientData for its command procedure. .PP Note that neither \fBTcl_SetCommandInfo\fR nor \fBTcl_SetCommandInfoFromToken\fR will change a command's namespace. Use \fBTcl_Eval\fR to call the \fBrename\fR command to do that. .PP \fBTcl_GetCommandName\fR provides a mechanism for tracking commands that have been renamed. Given a token returned by \fBTcl_CreateObjCommand\fR when the command was created, \fBTcl_GetCommandName\fR returns the string name of the command. If the command has been renamed since it was created, then \fBTcl_GetCommandName\fR returns the current name. |
| ︙ | ︙ |
Changes to doc/CrtSlave.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: CrtSlave.3,v 1.8.2.2 2003/07/18 15:20:51 dgp Exp $ '\" .so man.macros .TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_IsSafe, Tcl_MakeSafe, Tcl_CreateSlave, Tcl_GetSlave, Tcl_GetMaster, Tcl_GetInterpPath, Tcl_CreateAlias, Tcl_CreateAliasObj, Tcl_GetAlias, Tcl_GetAliasObj, Tcl_ExposeCommand, Tcl_HideCommand \- manage multiple Tcl interpreters, aliases and hidden commands. .SH SYNOPSIS |
| ︙ | ︙ | |||
136 137 138 139 140 141 142 | manual entry for the Tcl \fBinterp\fR command for details. If the creation of the new slave interpreter failed, \fBNULL\fR is returned. .PP \fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is ``safe'' (was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), \fB0\fR otherwise. .PP | | > | | > > > > | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | manual entry for the Tcl \fBinterp\fR command for details. If the creation of the new slave interpreter failed, \fBNULL\fR is returned. .PP \fBTcl_IsSafe\fR returns \fB1\fR if \fIinterp\fR is ``safe'' (was created with the \fBTCL_SAFE_INTERPRETER\fR flag specified), \fB0\fR otherwise. .PP \fBTcl_MakeSafe\fR marks \fIinterp\fR as ``safe'', so that future calls to \fBTcl_IsSafe\fR will return 1. It also removes all known potentially-unsafe core functionality (both commands and variables) from \fIinterp\fR. However, it cannot know what parts of an extension or application are safe and does not make any attempt to remove those parts, so safety is not guaranteed after calling \fBTcl_MakeSafe\fR. Callers will want to take care with their use of \fBTcl_MakeSafe\fR to avoid false claims of safety. For many situations, \fBTcl_CreateSlave\fR may be a better choice, since it creates interpreters in a known-safe state. .PP \fBTcl_GetSlave\fR returns a pointer to a slave interpreter of \fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. If no such slave interpreter exists, \fBNULL\fR is returned. .PP \fBTcl_GetMaster\fR returns a pointer to the master interpreter of \fIinterp\fR. If \fIinterp\fR has no master (it is a |
| ︙ | ︙ |
Changes to doc/CrtTrace.3.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: CrtTrace.3,v 1.6.2.1 2003/07/18 15:20:51 dgp Exp $ '\" .so man.macros .TH Tcl_CreateTrace 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateTrace, Tcl_CreateObjTrace, Tcl_DeleteTrace \- arrange for command execution to be traced .SH SYNOPSIS |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that's executed. See below for details on the calling sequence. .AP ClientData clientData in Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc Procedure to call when the trace is deleted. See below for details of | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that's executed. See below for details on the calling sequence. .AP ClientData clientData in Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc Procedure to call when the trace is deleted. See below for details of the calling sequence. A NULL pointer is permissible and results in no callback when the trace is deleted. .AP Tcl_Trace trace in Token for trace to be removed (return value from previous call to \fBTcl_CreateTrace\fR). .BE .SH DESCRIPTION .PP |
| ︙ | ︙ |
Changes to doc/Encoding.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Encoding.3,v 1.11.2.1 2003/07/18 16:56:24 dgp Exp $ '\" .so man.macros .TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_WinTCharToUtf, Tcl_WinUtfToTChar, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings. .SH SYNOPSIS |
| ︙ | ︙ | |||
170 171 172 173 174 175 176 | should be called to release it. When an \fIencoding\fR is no longer in use anywhere (i.e., it has been freed as many times as it has been gotten) \fBTcl_FreeEncoding\fR will release all storage the encoding was using and delete it from the database. .PP \fBTcl_ExternalToUtfDString\fR converts a source buffer \fIsrc\fR from the specified \fIencoding\fR into UTF-8. The converted bytes are stored in | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | should be called to release it. When an \fIencoding\fR is no longer in use anywhere (i.e., it has been freed as many times as it has been gotten) \fBTcl_FreeEncoding\fR will release all storage the encoding was using and delete it from the database. .PP \fBTcl_ExternalToUtfDString\fR converts a source buffer \fIsrc\fR from the specified \fIencoding\fR into UTF-8. The converted bytes are stored in \fIdstPtr\fR, which is then null-terminated. The caller should eventually call \fBTcl_DStringFree\fR to free any information stored in \fIdstPtr\fR. When converting, if any of the characters in the source buffer cannot be represented in the target encoding, a default fallback character will be used. The return value is a pointer to the value stored in the DString. .PP \fBTcl_ExternalToUtf\fR converts a source buffer \fIsrc\fR from the specified \fIencoding\fR into UTF-8. Up to \fIsrcLen\fR bytes are converted from the |
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | The source buffer contained a character that could not be represented in the target encoding and TCL_ENCODING_STOPONERROR was specified. .RE .LP \fBTcl_UtfToExternalDString\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. The converted bytes are stored in \fIdstPtr\fR, which is then terminated with the appropriate encoding-specific | | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | The source buffer contained a character that could not be represented in the target encoding and TCL_ENCODING_STOPONERROR was specified. .RE .LP \fBTcl_UtfToExternalDString\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. The converted bytes are stored in \fIdstPtr\fR, which is then terminated with the appropriate encoding-specific null. The caller should eventually call \fBTcl_DStringFree\fR to free any information stored in \fIdstPtr\fR. When converting, if any of the characters in the source buffer cannot be represented in the target encoding, a default fallback character will be used. The return value is a pointer to the value stored in the DString. .PP \fBTcl_UtfToExternal\fR converts a source buffer \fIsrc\fR from UTF-8 into the specified \fIencoding\fR. Up to \fIsrcLen\fR bytes are converted from |
| ︙ | ︙ |
Changes to doc/Environment.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Environment.3,v 1.1.18.1 2005/05/03 17:53:41 dgp Exp $ '\" .so man.macros .TH Tcl_PutEnv 3 "7.5" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_PutEnv \- procedures to manipulate the environment .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_PutEnv\fR(\fIstring\fR) .SH ARGUMENTS .AP "CONST char" *string in Info about environment variable in the form NAME=value. The \fIstring\fR argument is in the system encoding. .BE .SH DESCRIPTION .PP \fBTcl_PutEnv\fR sets an environment variable. The information is passed in a single string of the form NAME=value. This procedure is intended to be a stand-in for the UNIX \fBputenv\fR system call. All tcl-based applications using \fBputenv\fR should redefine it to \fBTcl_PutEnv\fR so that they will interface properly to the Tcl runtime. .SH KEYWORDS environment, variable |
Changes to doc/Eval.3.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Eval.3,v 1.12.2.3 2003/07/18 16:56:24 dgp Exp $ '\" .so man.macros .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts .SH SYNOPSIS |
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | int \fBTcl_EvalEx\fR(\fIinterp, script, numBytes, flags\fR) .sp int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | int \fBTcl_EvalEx\fR(\fIinterp, script, numBytes, flags\fR) .sp int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_VarEval\fR(\fIinterp, string, string, ... \fB(char *) NULL\fR) .sp int \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS |
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | Points to an array of pointers to objects; each object holds the value of a single word in the command to execute. .AP int numBytes in The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "CONST char" *script in | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | Points to an array of pointers to objects; each object holds the value of a single word in the command to execute. .AP int numBytes in The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "CONST char" *script in Points to first byte of script to execute (null-terminated and UTF-8). .AP char *string in String forming part of a Tcl script. .AP va_list argList in An argument list which must have been initialised using \fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. .BE |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step can be skipped if the object is evaluated again in the future. .PP The return value from \fBTcl_EvalObjEx\fR (and all the other procedures described here) is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, | | > | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | which are then executed. The bytecodes are saved in \fIobjPtr\fR so that the compilation step can be skipped if the object is evaluated again in the future. .PP The return value from \fBTcl_EvalObjEx\fR (and all the other procedures described here) is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. If the file couldn't be read then a Tcl error is returned to describe |
| ︙ | ︙ |
Changes to doc/ExprLong.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: ExprLong.3,v 1.6.2.1 2005/05/03 17:53:41 dgp Exp $ '\" .so man.macros .TH Tcl_ExprLong 3 7.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ExprLong, Tcl_ExprDouble, Tcl_ExprBoolean, Tcl_ExprString \- evaluate an expression .SH SYNOPSIS |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | \fBTcl_ExprBoolean\fR(\fIinterp, string, booleanPtr\fR) .sp int \fBTcl_ExprString\fR(\fIinterp, string\fR) .SH ARGUMENTS .AS Tcl_Interp *booleanPtr .AP Tcl_Interp *interp in | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | \fBTcl_ExprBoolean\fR(\fIinterp, string, booleanPtr\fR) .sp int \fBTcl_ExprString\fR(\fIinterp, string\fR) .SH ARGUMENTS .AS Tcl_Interp *booleanPtr .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIstring\fR. .VS 8.4 .AP "CONST char" *string in .VE Expression to be evaluated. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 | the value was zero and 1 otherwise. If the expression's actual value is a non-numeric string then it must be one of the values accepted by \fBTcl_GetBoolean\fR such as ``yes'' or ``no'', or else an error occurs. .PP \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. | < < < < < < | 94 95 96 97 98 99 100 101 102 103 104 105 106 | the value was zero and 1 otherwise. If the expression's actual value is a non-numeric string then it must be one of the values accepted by \fBTcl_GetBoolean\fR such as ``yes'' or ``no'', or else an error occurs. .PP \fBTcl_ExprString\fR returns the value of the expression as a string stored in the interpreter's result. .SH "SEE ALSO" Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj .SH KEYWORDS boolean, double, evaluate, expression, integer, object, string |
Changes to doc/ExprLongObj.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: ExprLongObj.3,v 1.3.12.1 2005/05/03 17:53:41 dgp Exp $ '\" .so man.macros .TH Tcl_ExprLongObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ExprLongObj, Tcl_ExprDoubleObj, Tcl_ExprBooleanObj, Tcl_ExprObj \- evaluate an expression .SH SYNOPSIS |
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | \fBTcl_ExprBooleanObj\fR(\fIinterp, objPtr, booleanPtr\fR) .sp int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | \fBTcl_ExprBooleanObj\fR(\fIinterp, objPtr, booleanPtr\fR) .sp int \fBTcl_ExprObj\fR(\fIinterp, objPtr, resultPtrPtr\fR) .SH ARGUMENTS .AS Tcl_Interp **resultPtrPtr out .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIobjPtr\fR. .AP Tcl_Obj *objPtr in Pointer to an object containing the expression to evaluate. .AP long *longPtr out Pointer to location in which to store the integer value of the expression. .AP int *doublePtr out Pointer to location in which to store the floating-point value of the |
| ︙ | ︙ |
Changes to doc/FileSystem.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2001 Vincent Darley '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2001 Vincent Darley '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: FileSystem.3,v 1.32.2.4 2005/06/20 16:57:43 dgp Exp $ '\" .so man.macros .TH Filesystem 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSLoadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_AllocStatBuf \- procedures to interact with any filesystem .SH SYNOPSIS |
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | Tcl_Obj* \fBTcl_FSListVolumes\fR(\fIvoid\fR) .sp int \fBTcl_FSEvalFile\fR(\fIinterp, pathPtr\fR) .sp int | | > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
Tcl_Obj*
\fBTcl_FSListVolumes\fR(\fIvoid\fR)
.sp
int
\fBTcl_FSEvalFile\fR(\fIinterp, pathPtr\fR)
.sp
int
\fBTcl_FSLoadFile\fR(\fIinterp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
handlePtr, unloadProcPtr\fR)
.sp
int
\fBTcl_FSMatchInDirectory\fR(\fIinterp, result, pathPtr, pattern, types\fR)
.sp
Tcl_Obj*
\fBTcl_FSLink\fR(\fIlinkNamePtr, toPtr, linkAction\fR)
.sp
|
| ︙ | ︙ | |||
196 197 198 199 200 201 202 203 204 205 206 207 208 209 | Name of a procedure to look up in the file's symbol table .AP "CONST char" *sym2 in Name of a procedure to look up in the file's symbol table .AP Tcl_PackageInitProc **proc1Ptr out Filled with the init function for this code. .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. .AP ClientData *clientDataPtr out Filled with the clientData value to pass to this code's unload function when it is called. .AP TclfsUnloadFileProc_ **unloadProcPtr out Filled with the function to use to unload this piece of code. .AP utimbuf *tval in The access and modification times in this structure are read and | > > | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | Name of a procedure to look up in the file's symbol table .AP "CONST char" *sym2 in Name of a procedure to look up in the file's symbol table .AP Tcl_PackageInitProc **proc1Ptr out Filled with the init function for this code. .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. .AP Tcl_LoadHandle *handlePtr out Filled with an abstract token representing the loaded file. .AP ClientData *clientDataPtr out Filled with the clientData value to pass to this code's unload function when it is called. .AP TclfsUnloadFileProc_ **unloadProcPtr out Filled with the function to use to unload this piece of code. .AP utimbuf *tval in The access and modification times in this structure are read and |
| ︙ | ︙ | |||
542 543 544 545 546 547 548 | Returns NULL or a valid internal path representation. This internal representation is cached, so that repeated calls to this function will not require additional conversions. .PP \fBTcl_FSGetTranslatedPath\fR attempts to extract the translated path from the given Tcl_Obj. .PP | | | | | | > > > > | > > > > | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 | Returns NULL or a valid internal path representation. This internal representation is cached, so that repeated calls to this function will not require additional conversions. .PP \fBTcl_FSGetTranslatedPath\fR attempts to extract the translated path from the given Tcl_Obj. .PP If the translation succeeds (i.e. the object is a valid path), then it is returned. Otherwise NULL will be returned, and an error message may be left in the interpreter. A "translated" path is one which contains no "~" or "~user" sequences (these have been expanded to their current representation in the filesystem). The object returned is owned by the caller, which must store it or call Tcl_DecrRefCount to ensure memory is freed. This function is of little practical use, and \fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, which must store it or call ckfree to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSNewNativePath\fR performs something like that reverse of the usual obj->path->nativerep conversions. If some code retrieves a path in native form (from, e.g. readlink or a native dialog), and that path is to be used at the Tcl level, then calling this function is an efficient way of creating the appropriate path object type. .PP |
| ︙ | ︙ | |||
775 776 777 778 779 780 781 | These fields contain addresses of functions which are used to associate a particular filesystem with a file path, and deal with the internal handling of path representations, for example copying and freeing such representations. .SH PATHINFILESYSTEMPROC .PP The \fIpathInFilesystemProc\fR field contains the address of a function | | | | | | | | | | | | | | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 | These fields contain addresses of functions which are used to associate a particular filesystem with a file path, and deal with the internal handling of path representations, for example copying and freeing such representations. .SH PATHINFILESYSTEMPROC .PP The \fIpathInFilesystemProc\fR field contains the address of a function which is called to determine whether a given path object belongs to this filesystem or not. Tcl will only call the rest of the filesystem functions with a path for which this function has returned \fBTCL_OK\fR. If the path does not belong, -1 should be returned (the behaviour of Tcl for any other return value is not defined). If \fBTCL_OK\fR is returned, then the optional \fBclientDataPtr\fR output parameter can be used to return an internal (filesystem specific) representation of the path, which will be cached inside the path object, and may be retrieved efficiently by the other filesystem functions. Tcl will simultaneously cache the fact that this path belongs to this filesystem. Such caches are invalidated when filesystem structures are added or removed from Tcl's internal list of known filesystems. .PP .CS typedef int Tcl_FSPathInFilesystemProc( Tcl_Obj *\fIpathPtr\fR, ClientData *\fIclientDataPtr\fR); .CE .SH DUPINTERNALREPPROC |
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 | contents of which the function should search for files or directories which have the correct type. In either case, \fIpathPtr\fR can be assumed to be both non-NULL and non-empty. It is not currently documented whether \fIpathPtr\fR will have a file separator at its end of not, so code should be flexible to both possibilities. .PP The return value is a standard Tcl result indicating whether an error | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 |
contents of which the function should search for files or directories
which have the correct type. In either case, \fIpathPtr\fR can be
assumed to be both non-NULL and non-empty. It is not currently
documented whether \fIpathPtr\fR will have a file separator at its end of
not, so code should be flexible to both possibilities.
.PP
The return value is a standard Tcl result indicating whether an error
occurred in the matching process. Error messages are placed in
\fIinterp\fR; on a \fBTCL_OK\fR result, results should be added to the
\fIresult\fR object given (which can be assumed to be a valid
unshared Tcl list). The matches added
to \fIresult\fR should include any path prefix given in \fIpathPtr\fR
(this usually means they will be absolute path specifications).
Note that if no matches are found, that simply leads to an empty
result; errors are only signaled for actual file or filesystem
problems which may occur during the matching process.
.PP
The \fBTcl_GlobTypeData\fR structure passed in the \fItypes\fR
parameter contains the following fields:
.CS
typedef struct Tcl_GlobTypeData {
/* Corresponds to bcdpfls as in 'find -t' */
int \fItype\fR;
/* Corresponds to file permissions */
int \fIperm\fR;
/* Acceptable mac type */
Tcl_Obj *\fImacType\fR;
/* Acceptable mac creator */
Tcl_Obj *\fImacCreator\fR;
} Tcl_GlobTypeData;
.CE
.PP
There are two specific cases which it is important to handle correctly,
both when \fItypes\fR is non-NULL. The two cases are when \fItypes->types
& TCL_GLOB_TYPE_DIR\fR or \fItypes->types & TCL_GLOB_TYPE_MOUNT\fR are
true (and in particular when the other flags are false). In the first of
these cases, the function must list the contained directories. Tcl uses
this to implement recursive globbing, so it is critical that filesystems
implement directory matching correctly. In the second of these cases,
with \fBTCL_GLOB_TYPE_MOUNT\fR, the filesystem must list the mount points
which lie within the given \fIpathPtr\fR (and in this case, \fIpathPtr\fR
need not lie within the same filesystem - different to all other cases in
which this function is called). Support for this is critical if Tcl is
to have seamless transitions between from one filesystem to another.
.SH UTIMEPROC
.PP
Function to process a \fBTcl_FSUtime()\fR call. Required to allow setting
(not reading) of times with 'file mtime', 'file atime' and the
open-r/open-w/fcopy implementation of 'file copy'.
.PP
.CS
|
| ︙ | ︙ |
Changes to doc/GetIndex.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: GetIndex.3,v 1.10.2.2 2006/04/06 18:57:24 dgp Exp $ '\" .so man.macros .TH Tcl_GetIndexFromObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_GetIndexFromObj, Tcl_GetIndexFromObjStruct \- lookup string in table of keywords .SH SYNOPSIS |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | Interpreter to use for error reporting; if NULL, then no message is provided on errors. .AP Tcl_Obj *objPtr in/out The string value of this object is used to search through \fItablePtr\fR. The internal representation is modified to hold the index of the matching table entry. .AP "CONST char" **tablePtr in | | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | Interpreter to use for error reporting; if NULL, then no message is provided on errors. .AP Tcl_Obj *objPtr in/out The string value of this object is used to search through \fItablePtr\fR. The internal representation is modified to hold the index of the matching table entry. .AP "CONST char" **tablePtr in An array of null-terminated strings. The end of the array is marked by a NULL string pointer. .AP "CONST VOID" *structTablePtr in An array of arbitrary type, typically some \fBstruct\fP type. The first member of the structure must be a null-terminated string. The size of the structure is given by \fIoffset\fP. .VS .AP int offset in The offset to add to structTablePtr to get to the next entry. The end of the array is marked by a NULL string pointer. .VE .AP "CONST char" *msg in |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | .PP This procedure provides an efficient way for looking up keywords, switch names, option names, and similar things where the value of an object must be one of a predefined set of values. \fIObjPtr\fR is compared against each of the strings in \fItablePtr\fR to find a match. A match occurs if \fIobjPtr\fR's string value is identical to one of the strings in | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | .PP This procedure provides an efficient way for looking up keywords, switch names, option names, and similar things where the value of an object must be one of a predefined set of values. \fIObjPtr\fR is compared against each of the strings in \fItablePtr\fR to find a match. A match occurs if \fIobjPtr\fR's string value is identical to one of the strings in \fItablePtr\fR, or if it is a non-empty unique abbreviation for exactly one of the strings in \fItablePtr\fR and the \fBTCL_EXACT\fR flag was not specified; in either case the index of the matching entry is stored at \fI*indexPtr\fR and TCL_OK is returned. .PP If there is no matching entry, TCL_ERROR is returned and an error message is left in \fIinterp\fR's |
| ︙ | ︙ |
Changes to doc/GetStdChan.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996 by Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996 by Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: GetStdChan.3,v 1.4.4.1 2006/06/06 20:07:36 dgp Exp $ '\" .so man.macros .TH Tcl_GetStdChannel 3 7.5 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_GetStdChannel, Tcl_SetStdChannel \- procedures for retrieving and replacing the standard channels |
| ︙ | ︙ | |||
48 49 50 51 52 53 54 55 56 57 58 59 60 61 | return value will be a valid channel, or NULL. .PP A new channel can be set for the standard channel specified by \fItype\fR by calling \fBTcl_SetStdChannel\fR with a new channel or NULL in the \fIchannel\fR argument. If the specified channel is closed by a later call to \fBTcl_Close\fR, then the corresponding standard channel will automatically be set to NULL. .PP If \fBTcl_GetStdChannel\fR is called before \fBTcl_SetStdChannel\fR, Tcl will construct a new channel to wrap the appropriate platform-specific standard file handle. If \fBTcl_SetStdChannel\fR is called before \fBTcl_GetStdChannel\fR, then the default channel will not be created. .PP If one of the standard channels is set to NULL, either by calling | > > > > > > > > > > | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | return value will be a valid channel, or NULL. .PP A new channel can be set for the standard channel specified by \fItype\fR by calling \fBTcl_SetStdChannel\fR with a new channel or NULL in the \fIchannel\fR argument. If the specified channel is closed by a later call to \fBTcl_Close\fR, then the corresponding standard channel will automatically be set to NULL. .PP If a non-NULL value for \fIchannel\fR is passed to \fBTcl_SetStdChannel\fR, then that same value should be passed to \fBTcl_RegisterChannel\fR, like so: .CS Tcl_RegisterChannel(NULL, channel); .CE This is a workaround for a misfeature in \fBTcl_SetStdChannel\fR that it fails to do some reference counting housekeeping. This misfeature cannot be corrected without contradicting the assumptions of some existing code that calls \fBTcl_SetStdChannel\fR. .PP If \fBTcl_GetStdChannel\fR is called before \fBTcl_SetStdChannel\fR, Tcl will construct a new channel to wrap the appropriate platform-specific standard file handle. If \fBTcl_SetStdChannel\fR is called before \fBTcl_GetStdChannel\fR, then the default channel will not be created. .PP If one of the standard channels is set to NULL, either by calling |
| ︙ | ︙ |
Changes to doc/Hash.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Hash.3,v 1.10.2.1 2003/07/18 16:56:24 dgp Exp $ '\" .so man.macros .TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_InitHashTable, Tcl_InitCustomHashTable, Tcl_InitObjHashTable, Tcl_DeleteHashTable, Tcl_CreateHashEntry, Tcl_DeleteHashEntry, Tcl_FindHashEntry, Tcl_GetHashValue, Tcl_SetHashValue, Tcl_GetHashKey, Tcl_FirstHashEntry, Tcl_NextHashEntry, Tcl_HashStats \- procedures to manage hash tables .SH SYNOPSIS |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | .PP \fBTcl_InitCustomHashTable\fR initializes a structure that describes a new hash table. The space for the structure is provided by the caller, not by the hash module. The value of \fIkeyType\fR indicates what kinds of keys will be used for all entries in the table. \fIKeyType\fR must have one of the following values: .IP \fBTCL_STRING_KEYS\fR 25 | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | .PP \fBTcl_InitCustomHashTable\fR initializes a structure that describes a new hash table. The space for the structure is provided by the caller, not by the hash module. The value of \fIkeyType\fR indicates what kinds of keys will be used for all entries in the table. \fIKeyType\fR must have one of the following values: .IP \fBTCL_STRING_KEYS\fR 25 Keys are null-terminated strings. They are passed to hashing routines using the address of the first character of the string. .IP \fBTCL_ONE_WORD_KEYS\fR 25 Keys are single-word values; they are passed to hashing routines and stored in hash table entries as ``char *'' values. The pointer value is the key; it need not (and usually doesn't) actually point to a string. |
| ︙ | ︙ |
Changes to doc/LinkVar.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: LinkVar.3,v 1.6.2.1 2003/07/18 16:56:24 dgp Exp $ '\" .so man.macros .TH Tcl_LinkVar 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_LinkVar, Tcl_UnlinkVar, Tcl_UpdateLinkedVar \- link Tcl variable to C variable .SH SYNOPSIS |
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR The C variable is of type \fBchar *\fR. .VS | | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR The C variable is of type \fBchar *\fR. .VS If its value is not NULL then it must be a pointer to a string allocated with \fBTcl_Alloc\fR or \fBckalloc\fR. .VE Whenever the Tcl variable is modified the current C string will be freed and new memory will be allocated to hold a copy of the variable's new value. If the C variable contains a NULL pointer then the Tcl variable will read as ``NULL''. .PP If the TCL_LINK_READ_ONLY flag is present in \fItype\fR then the variable will be read-only from Tcl, so that its value can only be changed by modifying the C variable. Attempts to write the variable from Tcl will be rejected with errors. .PP |
| ︙ | ︙ |
Changes to doc/Macintosh.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Macintosh.3,v 1.4.2.1 2003/07/18 16:56:24 dgp Exp $ '\" .so man.macros .TH Tcl_MacSetEventProc 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_MacSetEventProc, Tcl_MacConvertTextResource, Tcl_MacEvalResource, Tcl_MacFindResource, Tcl_GetOSTypeFromObj, Tcl_SetOSTypeObj, Tcl_NewOSTypeObj \- procedures to handle Macintosh resources and other Macintosh specifics .SH SYNOPSIS |
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | \fBTcl_MacEvalResource\fR extends the \fBsource\fR command to Macintosh resources. It sources Tcl code from a Text resource. Currently only sources the resource by name, file IDs may be supported at a later date. .PP \fBTcl_MacConvertTextResource\fR converts a TEXT resource into a Tcl suitable string. It mallocs the returned memory, converts ``\\r'' to | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | \fBTcl_MacEvalResource\fR extends the \fBsource\fR command to Macintosh resources. It sources Tcl code from a Text resource. Currently only sources the resource by name, file IDs may be supported at a later date. .PP \fBTcl_MacConvertTextResource\fR converts a TEXT resource into a Tcl suitable string. It mallocs the returned memory, converts ``\\r'' to ``\\n'', and appends a null. The caller has the responsibility for freeing the memory. .PP \fBTcl_MacFindResource\fR provides a higher level interface for loading resources. It is used by \fBresource read\fR. .PP \fBTcl_NewOSTypeObj\fR is used to create a new resource name type object. The object type is "ostype". |
| ︙ | ︙ |
Changes to doc/Notifier.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Notifier.3,v 1.9.2.1 2004/11/25 15:28:37 vasiljevic Exp $ '\" .so man.macros .TH Notifier 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces .SH SYNOPSIS |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 | \fBTcl_QueueEvent\fR(\fIevPtr, position\fR) .VS 8.1 .sp void \fBTcl_ThreadQueueEvent\fR(\fIthreadId, evPtr, position\fR) .sp void | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | \fBTcl_QueueEvent\fR(\fIevPtr, position\fR) .VS 8.1 .sp void \fBTcl_ThreadQueueEvent\fR(\fIthreadId, evPtr, position\fR) .sp void \fBTcl_ThreadAlert\fR(\fIthreadId\fR) .sp Tcl_ThreadId \fBTcl_GetCurrentThread\fR() .sp void \fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR) .sp |
| ︙ | ︙ |
Changes to doc/OpenFileChnl.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: OpenFileChnl.3,v 1.20.2.4 2004/07/16 22:22:15 andreas_kupries Exp $ .so man.macros .TH Tcl_OpenFileChannel 3 8.3 Tcl "Tcl Library Procedures" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_OpenFileChannel, Tcl_OpenCommandChannel, Tcl_MakeFileChannel, Tcl_GetChannel, Tcl_GetChannelNames, Tcl_GetChannelNamesEx, Tcl_RegisterChannel, Tcl_UnregisterChannel, Tcl_DetachChannel, Tcl_IsStandardChannel, Tcl_Close, Tcl_ReadChars, Tcl_Read, Tcl_GetsObj, Tcl_Gets, Tcl_WriteObj, Tcl_WriteChars, Tcl_Write, Tcl_Flush, Tcl_Seek, Tcl_Tell, Tcl_GetChannelOption, Tcl_SetChannelOption, Tcl_Eof, Tcl_InputBlocked, Tcl_InputBuffered, Tcl_OutputBuffered, Tcl_Ungets, Tcl_ReadRaw, Tcl_WriteRaw \- buffered I/O facilities using channels .SH SYNOPSIS |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 | \fBTcl_InputBuffered\fR(\fIchannel\fR) .VS 8.4 .sp int \fBTcl_OutputBuffered\fR(\fIchannel\fR) .VE .sp | > | | > | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | \fBTcl_InputBuffered\fR(\fIchannel\fR) .VS 8.4 .sp int \fBTcl_OutputBuffered\fR(\fIchannel\fR) .VE .sp .VS 8.4 Tcl_WideInt \fBTcl_Seek\fR(\fIchannel, offset, seekMode\fR) .sp Tcl_WideInt \fBTcl_Tell\fR(\fIchannel\fR) .VE 8.4 .sp int \fBTcl_GetChannelOption\fR(\fIinterp, channel, optionName, optionValue\fR) .sp int \fBTcl_SetChannelOption\fR(\fIinterp, channel, optionName, newValue\fR) .sp |
| ︙ | ︙ | |||
198 199 200 201 202 203 204 | A buffer containing the characters to output to the channel. .AP "CONST char" *byteBuf in A buffer containing the bytes to output to the channel. .AP int bytesToWrite in The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and output to the channel. .VE | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | A buffer containing the characters to output to the channel. .AP "CONST char" *byteBuf in A buffer containing the bytes to output to the channel. .AP int bytesToWrite in The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and output to the channel. .VE .AP Tcl_WideInt offset in How far to move the access point in the channel at which the next input or output operation will be applied, measured in bytes from the position given by \fIseekMode\fR. May be either positive or negative. .AP int seekMode in Relative to which point to seek; used with \fIoffset\fR to calculate the new access point for the channel. Legal values are \fBSEEK_SET\fR, \fBSEEK_CUR\fR, and \fBSEEK_END\fR. |
| ︙ | ︙ | |||
428 429 430 431 432 433 434 435 436 437 438 439 440 441 | \fBTcl_ReadChars\fR consumes bytes from \fIchannel\fR, converting the bytes to UTF-8 based on the channel's encoding and storing the produced data in \fIreadObjPtr\fR's string representation. The return value of \fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR, that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the return value is \-1 and \fBTcl_ReadChars\fR records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. .PP The return value may be smaller than the value to read, indicating that less data than requested was available. This is called a \fIshort read\fR. In blocking mode, this can only happen on an end-of-file. In nonblocking mode, a short read can also occur if there is not enough input currently available: \fBTcl_ReadChars\fR returns a short count rather than waiting for more data. | > > > > | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 | \fBTcl_ReadChars\fR consumes bytes from \fIchannel\fR, converting the bytes to UTF-8 based on the channel's encoding and storing the produced data in \fIreadObjPtr\fR's string representation. The return value of \fBTcl_ReadChars\fR is the number of characters, up to \fIcharsToRead\fR, that were stored in \fIreadObjPtr\fR. If an error occurs while reading, the return value is \-1 and \fBTcl_ReadChars\fR records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. .PP Setting \fIcharsToRead\fR to \fB-1\fR will cause the command to read all characters currently available (non-blocking) or everything until eof (blocking mode). .PP The return value may be smaller than the value to read, indicating that less data than requested was available. This is called a \fIshort read\fR. In blocking mode, this can only happen on an end-of-file. In nonblocking mode, a short read can also occur if there is not enough input currently available: \fBTcl_ReadChars\fR returns a short count rather than waiting for more data. |
| ︙ | ︙ | |||
464 465 466 467 468 469 470 | .PP \fBTcl_Read\fR is similar to \fBTcl_ReadChars\fR, except that it doesn't do encoding conversions, regardless of the channel's encoding. It is deprecated and exists for backwards compatibility with non-internationalized Tcl extensions. It consumes bytes from \fIchannel\fR and stores them in \fIreadBuf\fR, performing end-of-line translations on the way. The return value of \fBTcl_Read\fR is the number of bytes, up to \fIbytesToRead\fR, written in | | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 | .PP \fBTcl_Read\fR is similar to \fBTcl_ReadChars\fR, except that it doesn't do encoding conversions, regardless of the channel's encoding. It is deprecated and exists for backwards compatibility with non-internationalized Tcl extensions. It consumes bytes from \fIchannel\fR and stores them in \fIreadBuf\fR, performing end-of-line translations on the way. The return value of \fBTcl_Read\fR is the number of bytes, up to \fIbytesToRead\fR, written in \fIreadBuf\fR. The buffer produced by \fBTcl_Read\fR is not null-terminated. Its contents are valid from the zeroth position up to and excluding the position indicated by the return value. .PP \fBTcl_ReadRaw\fR is the same as \fBTcl_Read\fR but does not compensate for stacking. While \fBTcl_Read\fR (and the other functions in the API) always get their data from the topmost channel in the stack the supplied channel is part of, \fBTcl_ReadRaw\fR does |
| ︙ | ︙ | |||
520 521 522 523 524 525 526 | .SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE" .PP \fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at \fIcharBuf\fR. The UTF-8 characters in the buffer are converted to the channel's encoding and queued for output to \fIchannel\fR. If \fIbytesToWrite\fR is negative, \fBTcl_WriteChars\fR expects \fIcharBuf\fR | | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 | .SH "TCL_WRITECHARS, TCL_WRITEOBJ, AND TCL_WRITE" .PP \fBTcl_WriteChars\fR accepts \fIbytesToWrite\fR bytes of character data at \fIcharBuf\fR. The UTF-8 characters in the buffer are converted to the channel's encoding and queued for output to \fIchannel\fR. If \fIbytesToWrite\fR is negative, \fBTcl_WriteChars\fR expects \fIcharBuf\fR to be null-terminated and it outputs everything up to the null. .PP Data queued for output may not appear on the output device immediately, due to internal buffering. If the data should appear immediately, call \fBTcl_Flush\fR after the call to \fBTcl_WriteChars\fR, or set the \fB\-buffering\fR option on the channel to \fBnone\fR. If you wish the data to appear as soon as a complete line is accepted for output, set the \fB\-buffering\fR option on the channel to \fBline\fR mode. |
| ︙ | ︙ | |||
558 559 560 561 562 563 564 | .PP \fBTcl_Write\fR is similar to \fBTcl_WriteChars\fR except that it doesn't do encoding conversions, regardless of the channel's encoding. It is deprecated and exists for backwards compatibility with non-internationalized Tcl extensions. It accepts \fIbytesToWrite\fR bytes of data at \fIbyteBuf\fR and queues them for output to \fIchannel\fR. If \fIbytesToWrite\fR is negative, \fBTcl_Write\fR expects \fIbyteBuf\fR to be | | | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 | .PP \fBTcl_Write\fR is similar to \fBTcl_WriteChars\fR except that it doesn't do encoding conversions, regardless of the channel's encoding. It is deprecated and exists for backwards compatibility with non-internationalized Tcl extensions. It accepts \fIbytesToWrite\fR bytes of data at \fIbyteBuf\fR and queues them for output to \fIchannel\fR. If \fIbytesToWrite\fR is negative, \fBTcl_Write\fR expects \fIbyteBuf\fR to be null-terminated and it outputs everything up to the null. .PP \fBTcl_WriteRaw\fR is the same as \fBTcl_Write\fR but does not compensate for stacking. While \fBTcl_Write\fR (and the other functions in the API) always feed their input to the topmost channel in the stack the supplied channel is part of, \fBTcl_WriteRaw\fR does not. Thus this function is \fBonly\fR usable for transformational channel drivers, i.e. drivers used in the middle of a stack of |
| ︙ | ︙ |
Changes to doc/ParseCmd.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: ParseCmd.3,v 1.10.2.2 2005/09/15 23:21:37 msofer Exp $ '\" .so man.macros .TH Tcl_ParseCommand 3 8.3 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions .SH SYNOPSIS |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | \fBTcl_ParseVar\fR(\fIinterp, string, termPtr\fR) .sp \fBTcl_FreeParse\fR(\fIusedParsePtr\fR) .sp Tcl_Obj * \fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) .sp | < > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | \fBTcl_ParseVar\fR(\fIinterp, string, termPtr\fR) .sp \fBTcl_FreeParse\fR(\fIusedParsePtr\fR) .sp Tcl_Obj * \fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) .sp int \fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR) .SH ARGUMENTS .AS Tcl_Interp *usedParsePtr .AP Tcl_Interp *interp out For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, used only for error reporting; if NULL, then no error messages are left after errors. |
| ︙ | ︙ | |||
104 105 106 107 108 109 110 | structure of the command (see below for details). If an error occurred in parsing the command then \fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's result, and no information is left at \fI*parsePtr\fR. .PP \fBTcl_ParseExpr\fR parses Tcl expressions. Given a pointer to a script containing an expression, | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | structure of the command (see below for details). If an error occurred in parsing the command then \fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's result, and no information is left at \fI*parsePtr\fR. .PP \fBTcl_ParseExpr\fR parses Tcl expressions. Given a pointer to a script containing an expression, \fBTcl_ParseExpr\fR parses the expression. If the expression was parsed successfully, \fBTcl_ParseExpr\fR returns \fBTCL_OK\fR and fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the expression (see below for details). If an error occurred in parsing the command then \fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's result, and no information is left at \fI*parsePtr\fR. |
| ︙ | ︙ | |||
186 187 188 189 190 191 192 | a Tcl_Parse structure. The tokens typically consist of all the tokens in a word or all the tokens that make up the index for a reference to an array variable. \fBTcl_EvalTokensStandard\fR performs the substitutions requested by the tokens and concatenates the resulting values. The return value from \fBTcl_EvalTokensStandard\fR is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, | | > | | | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
a Tcl_Parse structure. The tokens typically consist
of all the tokens in a word or all the tokens that make up the index for
a reference to an array variable. \fBTcl_EvalTokensStandard\fR performs the
substitutions requested by the tokens and concatenates the
resulting values.
The return value from \fBTcl_EvalTokensStandard\fR is a Tcl completion
code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR,
\fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly
some other integer value originating in an extension.
In addition, a result value or error message is left in \fIinterp\fR's
result; it can be retrieved using \fBTcl_GetObjResult\fR.
.PP
\fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in
the return convention used: it returns the result in a new Tcl_Obj.
The reference count of the object returned as result has been
incremented, so the caller must
invoke \fBTcl_DecrRefCount\fR when it is finished with the object.
If an error or other exception occurs while evaluating the tokens
(such as a reference to a non-existent variable) then the return value
is NULL and an error message is left in \fIinterp\fR's result. The use
of \fBTcl_EvalTokens\fR is deprecated.
.SH "TCL_PARSE STRUCTURE"
.PP
\fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR,
\fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR
return parse information in two data structures, Tcl_Parse and Tcl_Token:
.CS
typedef struct Tcl_Parse {
CONST char *\fIcommentStart\fR;
int \fIcommentSize\fR;
CONST char *\fIcommandStart\fR;
int \fIcommandSize\fR;
int \fInumWords\fR;
Tcl_Token *\fItokenPtr\fR;
int \fInumTokens\fR;
...
} Tcl_Parse;
typedef struct Tcl_Token {
int \fItype\fR;
CONST char *\fIstart\fR;
int \fIsize\fR;
int \fInumComponents\fR;
} Tcl_Token;
.CE
.PP
The first five fields of a Tcl_Parse structure
are filled in only by \fBTcl_ParseCommand\fR.
|
| ︙ | ︙ |
Changes to doc/PkgRequire.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: PkgRequire.3,v 1.6.2.1 2006/09/22 01:26:22 andreas_kupries Exp $ '\" .so man.macros .TH Tcl_PkgRequire 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_PkgRequire, Tcl_PkgRequireEx, Tcl_PkgPresent, Tcl_PkgPresentEx, Tcl_PkgProvide, Tcl_PkgProvideEx \- package version control .SH SYNOPSIS |
| ︙ | ︙ | |||
50 51 52 53 54 55 56 | .AP ClientData clientData in Arbitrary value to be associated with the package. .AP ClientData *clientDataPtr out Pointer to place to store the value associated with the matching package. It is only changed if the pointer is not NULL and the function completed successfully. .BE | < | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | .AP ClientData clientData in Arbitrary value to be associated with the package. .AP ClientData *clientDataPtr out Pointer to place to store the value associated with the matching package. It is only changed if the pointer is not NULL and the function completed successfully. .BE .SH DESCRIPTION .PP These procedures provide C-level interfaces to Tcl's package and version management facilities. .PP \fBTcl_PkgRequire\fR is equivalent to the \fBpackage require\fR command, \fBTcl_PkgPresent\fR is equivalent to the \fBpackage present\fR |
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | if an error occurs it returns TCL_ERROR and leaves an error message in the interpreter's result. .PP \fBTcl_PkgProvideEx\fR, \fBTcl_PkgPresentEx\fR and \fBTcl_PkgRequireEx\fR allow the setting and retrieving of the client data associated with the package. In all other respects they are equivalent to the matching functions. | < | 77 78 79 80 81 82 83 84 85 | if an error occurs it returns TCL_ERROR and leaves an error message in the interpreter's result. .PP \fBTcl_PkgProvideEx\fR, \fBTcl_PkgPresentEx\fR and \fBTcl_PkgRequireEx\fR allow the setting and retrieving of the client data associated with the package. In all other respects they are equivalent to the matching functions. .SH KEYWORDS package, present, provide, require, version |
Changes to doc/SetVar.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: SetVar.3,v 1.7.2.2 2004/08/16 14:18:25 msofer Exp $ '\" .so man.macros .TH Tcl_SetVar 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_SetVar2Ex, Tcl_SetVar, Tcl_SetVar2, Tcl_ObjSetVar2, Tcl_GetVar2Ex, Tcl_GetVar, Tcl_GetVar2, Tcl_ObjGetVar2, Tcl_UnsetVar, Tcl_UnsetVar2 \- manipulate Tcl variables .SH SYNOPSIS |
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | .AP "CONST char" *varName in Name of variable. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array. .AP "CONST char" *newValue in | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | .AP "CONST char" *varName in Name of variable. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array. .AP "CONST char" *newValue in New value for variable, specified as a null-terminated string. A copy of this value is stored in the variable. .AP Tcl_Obj *part1Ptr in Points to a Tcl object containing the variable's name. The name may include a series of \fB::\fR namespace qualifiers to specify a variable in a particular namespace. May refer to a scalar variable or an element of an array variable. .AP Tcl_Obj *part2Ptr in |
| ︙ | ︙ | |||
217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
\fBTCL_LIST_ELEMENT\fR
If this bit is set, then \fInewValue\fR is converted to a valid
Tcl list element before setting (or appending to) the variable.
A separator space is appended before the new list element unless
the list element is going to be the first element in a list or
sublist (i.e. the variable's current value is empty, or contains
the single character ``{'', or ends in `` }'').
.PP
\fBTcl_GetVar\fR and \fBTcl_GetVar2\fR
return the current value of a variable.
The arguments to these procedures are treated in the same way
as the arguments to \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR.
Under normal circumstances, the return value is a pointer
to the variable's value (which is stored in Tcl's variable
| > > > | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
\fBTCL_LIST_ELEMENT\fR
If this bit is set, then \fInewValue\fR is converted to a valid
Tcl list element before setting (or appending to) the variable.
A separator space is appended before the new list element unless
the list element is going to be the first element in a list or
sublist (i.e. the variable's current value is empty, or contains
the single character ``{'', or ends in `` }'').
When appending, the original value of the variable must also be
a valid list, so that the operation is the appending of a new
list element onto a list.
.PP
\fBTcl_GetVar\fR and \fBTcl_GetVar2\fR
return the current value of a variable.
The arguments to these procedures are treated in the same way
as the arguments to \fBTcl_SetVar\fR and \fBTcl_SetVar2\fR.
Under normal circumstances, the return value is a pointer
to the variable's value (which is stored in Tcl's variable
|
| ︙ | ︙ |
Changes to doc/StringObj.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: StringObj.3,v 1.13.2.1 2003/07/18 16:56:24 dgp Exp $ '\" .so man.macros .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendObjToObj, Tcl_SetObjLength, Tcl_ConcatObj, Tcl_AttemptSetObjLength \- manipulate Tcl objects as strings .SH SYNOPSIS |
| ︙ | ︙ | |||
114 115 116 117 118 119 120 | .AP "CONST char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialised using \fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. .AP int newLength in New length for the string value of \fIobjPtr\fR, not including the | | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | .AP "CONST char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialised using \fBTCL_VARARGS_START\fR, and cleared using \fBva_end\fR. .AP int newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .AP int objc in The number of elements to concatenate. .AP Tcl_Obj *objv[] in The array of objects to concatenate. .BE .SH DESCRIPTION |
| ︙ | ︙ |
Changes to doc/Tcl.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Tcl.n,v 1.9.2.1 2005/12/19 10:09:50 dkf Exp $ '\" .so man.macros .TH Tcl n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME Tcl \- Tool Command Language .SH SYNOPSIS |
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | by a close bracket (``]''). The result of the script (i.e. the result of its last command) is substituted into the word in place of the brackets and all of the characters between them. There may be any number of command substitutions in a single word. Command substitution is not performed on words enclosed in braces. .IP "[7] \fBVariable substitution.\fR" | | > | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | by a close bracket (``]''). The result of the script (i.e. the result of its last command) is substituted into the word in place of the brackets and all of the characters between them. There may be any number of command substitutions in a single word. Command substitution is not performed on words enclosed in braces. .IP "[7] \fBVariable substitution.\fR" If a word contains a dollar-sign (``$'') followed by one of the forms described below, then Tcl performs \fIvariable substitution\fR: the dollar-sign and the following characters are replaced in the word by the value of a variable. Variable substitution may take any of the following forms: .RS .TP 15 \fB$\fIname\fR \fIName\fR is the name of a scalar variable; the name is a sequence |
| ︙ | ︙ |
Changes to doc/Thread.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Thread.3,v 1.14.2.2 2004/11/25 15:48:52 vasiljevic Exp $ '\" .so man.macros .TH Threads 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_ConditionNotify, Tcl_ConditionWait, Tcl_ConditionFinalize, Tcl_GetThreadData, Tcl_MutexLock, Tcl_MutexUnlock, Tcl_MutexFinalize, Tcl_CreateThread, Tcl_JoinThread \- Tcl thread support. .SH SYNOPSIS |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | .sp int \fBTcl_JoinThread\fR(\fIid, result\fR) .SH ARGUMENTS .AS Tcl_ThreadDataKey *keyPtr .AP Tcl_Condition *condPtr in A condition variable, which must be associated with a mutex lock. | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | .sp int \fBTcl_JoinThread\fR(\fIid, result\fR) .SH ARGUMENTS .AS Tcl_ThreadDataKey *keyPtr .AP Tcl_Condition *condPtr in A condition variable, which must be associated with a mutex lock. .AP Tcl_Mutex *mutexPtr in A mutex lock. .AP Tcl_Time *timePtr in A time limit on the condition wait. NULL to wait forever. Note that a polling value of 0 seconds doesn't make much sense. .AP Tcl_ThreadDataKey *keyPtr in This identifies a block of thread local storage. The key should be static and process-wide, yet each thread will end up associating |
| ︙ | ︙ | |||
136 137 138 139 140 141 142 | the \fBNotifier\fR manual page for more information on these procedures. .PP In this release, the Tcl language itself provides no support for creating multithreaded scripts (for example, scripts that could spawn a Tcl interpreter in a separate thread). If you need to add this feature at this time, see the \fItclThreadTest.c\fR file in the Tcl source distribution for an experimental implementation | | | > > > > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | the \fBNotifier\fR manual page for more information on these procedures. .PP In this release, the Tcl language itself provides no support for creating multithreaded scripts (for example, scripts that could spawn a Tcl interpreter in a separate thread). If you need to add this feature at this time, see the \fItclThreadTest.c\fR file in the Tcl source distribution for an experimental implementation or use the Tcl "Threading Extension" package implementing thread creation and management commands at the script level. .SH DESCRIPTION A mutex is a lock that is used to serialize all threads through a piece of code by calling \fBTcl_MutexLock\fR and \fBTcl_MutexUnlock\fR. If one thread holds a mutex, any other thread calling \fBTcl_MutexLock\fR will block until \fBTcl_MutexUnlock\fR is called. .VS A mutex can be destroyed after its use by calling \fBTcl_MutexFinalize\fR. The result of locking a mutex twice from the same thread is undefined. On some platforms it will result in a deadlock. .VE The \fBTcl_MutexLock\fR, \fBTcl_MutexUnlock\fR and \fBTcl_MutexFinalize\fR procedures are defined as empty macros if not compiling with threads enabled. For declaration of mutexes the \fBTCL_DECLARE_MUTEX\fR macro should be used. This macro assures correct mutex handling even when the core is compiled without threads enabled. .PP A condition variable is used as a signaling mechanism: a thread can lock a mutex and then wait on a condition variable with \fBTcl_ConditionWait\fR. This atomically releases the mutex lock and blocks the waiting thread until another thread calls \fBTcl_ConditionNotify\fR. The caller of \fBTcl_ConditionNotify\fR should have the associated mutex held by previously calling \fBTcl_MutexLock\fR, |
| ︙ | ︙ |
Changes to doc/Utf.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: Utf.3,v 1.13.2.2 2003/07/18 22:15:45 dkf Exp $ '\" .so man.macros .TH Utf 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_UniChar, Tcl_UniCharCaseMatch, Tcl_UniCharNcasecmp, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings. .SH SYNOPSIS |
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | .AP int ch in The Tcl_UniChar to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP "CONST char" *src in Pointer to a UTF-8 string. .AP "CONST Tcl_UniChar" *uniStr in | | | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | .AP int ch in The Tcl_UniChar to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP "CONST char" *src in Pointer to a UTF-8 string. .AP "CONST Tcl_UniChar" *uniStr in A null-terminated Unicode string. .AP "CONST Tcl_UniChar" *uniPattern in A null-terminated Unicode string. .AP int len in The length of the UTF-8 string in bytes (not UTF-8 characters). If negative, all bytes up to the first null byte are used. .AP int numChars in The length of the Unicode string in characters. Must be greater than or equal to 0. .AP "Tcl_DString" *dstPtr in/out |
| ︙ | ︙ | |||
139 140 141 142 143 144 145 | in \fIbuf\fR. .PP \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the number of bytes read from \fIsrc\fR.. The caller must ensure that the source buffer is long enough such that this routine does not run off the end and dereference non-existent or random memory; if the source buffer | | | | | | | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 | in \fIbuf\fR. .PP \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the number of bytes read from \fIsrc\fR.. The caller must ensure that the source buffer is long enough such that this routine does not run off the end and dereference non-existent or random memory; if the source buffer is known to be null-terminated, this will not happen. If the input is not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x0000 and 0x00ff and return 1. .PP \fBTcl_UniCharToUtfDString\fR converts the given Unicode string to UTF-8, storing the result in a previously-initialized \fBTcl_DString\fR. You must specify the length of the given Unicode string. The return value is a pointer to the UTF-8 representation of the Unicode string. Storage for the return value is appended to the end of the \fBTcl_DString\fR. .PP \fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode, storing the result in the previously-initialized \fBTcl_DString\fR. you may either specify the length of the given UTF-8 string or "-1", in which case \fBTcl_UtfToUniCharDString\fR uses \fBstrlen\fR to calculate the length. The return value is a pointer to the Unicode representation of the UTF-8 string. Storage for the return value is appended to the end of the \fBTcl_DString\fR. The Unicode string is terminated with a Unicode null character. .PP \fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode characters. It accepts a null-terminated Unicode string and returns the number of Unicode characters (not bytes) in that string. .PP \fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to \fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters. They accepts two null-terminated Unicode strings and the number of characters to compare. Both strings are assumed to be at least \fIlen\fR characters long. \fBTcl_UniCharNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. \fBTcl_UniCharNcasecmp\fR is the Unicode case insensitive version. .PP .VS 8.4 \fBTcl_UniCharCaseMatch\fR is the Unicode equivalent to \fBTcl_StringCaseMatch\fR. It accepts a null-terminated Unicode string, a Unicode pattern, and a boolean value specifying whether the match should be case sensitive and returns whether the string matches the pattern. .VE 8.4 .PP \fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It accepts two null-terminated UTF-8 strings and the number of characters to compare. (Both strings are assumed to be at least \fIlen\fR characters long.) \fBTcl_UtfNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. .PP |
| ︙ | ︙ | |||
205 206 207 208 209 210 211 | that the UTF-8 string is properly formed. This routine is used by procedures that are operating on a byte at a time and need to know if a full Tcl_UniChar has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string \fIsrc\fR. The length of the source string is \fIlen\fR bytes. If the | | | | | > | > | > | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 | that the UTF-8 string is properly formed. This routine is used by procedures that are operating on a byte at a time and need to know if a full Tcl_UniChar has been seen. .PP \fBTcl_NumUtfChars\fR corresponds to \fBstrlen\fR for UTF-8 strings. It returns the number of Tcl_UniChars that are represented by the UTF-8 string \fIsrc\fR. The length of the source string is \fIlen\fR bytes. If the length is negative, all bytes up to the first null byte are used. .PP \fBTcl_UtfFindFirst\fR corresponds to \fBstrchr\fR for UTF-8 strings. It returns a pointer to the first occurrence of the Tcl_UniChar \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is considered part of the UTF-8 string. .PP \fBTcl_UtfFindLast\fR corresponds to \fBstrrchr\fR for UTF-8 strings. It returns a pointer to the last occurrence of the Tcl_UniChar \fIch\fR in the null-terminated UTF-8 string \fIsrc\fR. The null terminator is considered part of the UTF-8 string. .PP Given \fIsrc\fR, a pointer to some location in a UTF-8 string, \fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the string. The caller must not ask for the next character after the last character in the string if the string is not terminated by a null character. .PP Given \fIsrc\fR, a pointer to some location in a UTF-8 string (or to a null byte immediately following such a string), \fBTcl_UtfPrev\fR returns a pointer to the closest preceding byte that starts a UTF-8 character. This function will not back up to a position before \fIstart\fR, the start of the UTF-8 string. If \fIsrc\fR was already at \fIstart\fR, the return value will be \fIstart\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the Pascal Ord() function. It returns the Tcl_UniChar represented at the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR |
| ︙ | ︙ |
Changes to doc/after.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: after.n,v 1.3.18.2 2004/10/27 14:23:41 dkf Exp $ '\" .so man.macros .TH after n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME after \- Execute a command after a time delay |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 104 105 106 107 108 109 | .LP The \fBafter \fIms\fR and \fBafter idle\fR forms of the command assume that the application is event driven: the delayed commands will not be executed unless the application enters the event loop. In applications that are not normally event-driven, such as \fBtclsh\fR, the event loop can be entered with the \fBvwait\fR and \fBupdate\fR commands. .SH "SEE ALSO" bgerror(n), concat(n), update(n), vwait(n) .SH KEYWORDS cancel, delay, idle callback, sleep, time | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
.LP
The \fBafter \fIms\fR and \fBafter idle\fR forms of the command
assume that the application is event driven: the delayed commands
will not be executed unless the application enters the event loop.
In applications that are not normally event-driven, such as
\fBtclsh\fR, the event loop can be entered with the \fBvwait\fR
and \fBupdate\fR commands.
.SH "EXAMPLES"
This defines a command to make Tcl do nothing at all for \fIN\fR
seconds:
.CS
proc sleep {N} {
\fBafter\fR [expr {int($N * 1000)}]
}
.CE
.PP
This arranges for the command \fIwake_up\fR to be run in eight hours
(providing the event loop is active at that time):
.CS
\fBafter\fR [expr {1000 * 60 * 60 * 8}] wake_up
.CE
.PP
The following command can be used to do long-running calculations (as
represented here by \fI::my_calc::one_step\fR, which is assumed to
return a boolean indicating whether another step should be performed)
in a step-by-step fashion, though the calculation itself needs to be
arranged so it can work step-wise. This technique is extra careful to
ensure that the event loop is not starved by the rescheduling of
processing steps (arranging for the next step to be done using an
already-triggered timer event only when the event queue has been
drained) and is useful when you want to ensure that a Tk GUI remains
responsive during a slow task.
.CS
proc doOneStep {} {
if {[::my_calc::one_step]} {
\fBafter idle\fR [list \fBafter\fR 0 doOneStep]
}
}
doOneStep
.CE
.SH "SEE ALSO"
bgerror(n), concat(n), update(n), vwait(n)
.SH KEYWORDS
cancel, delay, idle callback, sleep, time
|
Changes to doc/append.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: append.n,v 1.4.2.1 2004/10/27 09:35:38 dkf Exp $ '\" .so man.macros .TH append n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME append \- Append to variable |
| ︙ | ︙ | |||
25 26 27 28 29 30 31 32 33 34 35 36 37 | \fIvalue\fR arguments. The result of this command is the new value stored in variable \fIvarName\fR. This command provides an efficient way to build up long variables incrementally. For example, ``\fBappend a $b\fR'' is much more efficient than ``\fBset a $a$b\fR'' if \fB$a\fR is long. .SH "SEE ALSO" concat(n), lappend(n) .SH KEYWORDS append, variable | > > > > > > > > > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
\fIvalue\fR arguments.
The result of this command is the new value stored in variable
\fIvarName\fR.
This command provides an efficient way to build up long
variables incrementally.
For example, ``\fBappend a $b\fR'' is much more efficient than
``\fBset a $a$b\fR'' if \fB$a\fR is long.
.SH EXAMPLE
Building a string of comma-separated numbers piecemeal using a loop.
.CS
set var 0
for {set i 1} {$i<=10} {incr i} {
\fBappend\fR var "," $i
}
puts $var
# Prints 0,1,2,3,4,5,6,7,8,9,10
.CE
.SH "SEE ALSO"
concat(n), lappend(n)
.SH KEYWORDS
append, variable
|
Changes to doc/array.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: array.n,v 1.8.18.3 2004/10/27 14:23:41 dkf Exp $ '\" .so man.macros .TH array n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME array \- Manipulate array variables |
| ︙ | ︙ | |||
111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | individual elements in the array. When the search has been completed, the \fBarray donesearch\fR command should be invoked. The return value is a search identifier that must be used in \fBarray nextelement\fR and \fBarray donesearch\fR commands; it allows multiple searches to be underway simultaneously for the same array. .VS 8.4 .TP \fBarray statistics \fIarrayName\fR Returns statistics about the distribution of data within the hashtable that represents the array. This information includes the number of entries in the table, the number of buckets, and the utilization of the buckets. .VE 8.4 .VS 8.3 .TP \fBarray unset \fIarrayName\fR ?\fIpattern\fR? Unsets all of the elements in the array that match \fIpattern\fR (using the matching rules of \fBstring match\fR). If \fIarrayName\fR isn't the name of an array variable or there are no matching elements in the array, no error will be raised. If \fIpattern\fR is omitted and \fIarrayName\fR is an array variable, then the command unsets the entire array. The command always returns an empty string. .VE 8.3 | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
individual elements in the array.
When the search has been completed, the \fBarray donesearch\fR
command should be invoked.
The return value is a
search identifier that must be used in \fBarray nextelement\fR
and \fBarray donesearch\fR commands; it allows multiple
searches to be underway simultaneously for the same array.
It is currently more efficient and easier to use either the \fBarray
get\fR or \fBarray names\fR, together with \fBforeach\fR, to iterate
over all but very large arrays. See the examples below for how to do
this.
.VS 8.4
.TP
\fBarray statistics \fIarrayName\fR
Returns statistics about the distribution of data within the hashtable
that represents the array. This information includes the number of
entries in the table, the number of buckets, and the utilization of
the buckets.
.VE 8.4
.VS 8.3
.TP
\fBarray unset \fIarrayName\fR ?\fIpattern\fR?
Unsets all of the elements in the array that match \fIpattern\fR (using the
matching rules of \fBstring match\fR). If \fIarrayName\fR isn't the name
of an array variable or there are no matching elements in the array, no
error will be raised. If \fIpattern\fR is omitted and \fIarrayName\fR is
an array variable, then the command unsets the entire array.
The command always returns an empty string.
.VE 8.3
.SH EXAMPLES
.CS
\fBarray set\fR colorcount {
red 1
green 5
blue 4
white 9
}
foreach {color count} [\fBarray get\fR colorcount] {
puts "Color: $color Count: $count"
}
=> Color: blue Count: 4
Color: white Count: 9
Color: green Count: 5
Color: red Count: 1
foreach color [\fBarray names\fR colorcount] {
puts "Color: $color Count: $colorcount($color)"
}
=> Color: blue Count: 4
Color: white Count: 9
Color: green Count: 5
Color: red Count: 1
foreach color [lsort [array names colorcount]] {
puts "Color: $color Count: $colorcount($color)"
}
=> Color: blue Count: 4
Color: green Count: 5
Color: red Count: 1
Color: white Count: 9
\fBarray statistics\fR colorcount
=> 4 entries in table, 4 buckets
number of buckets with 0 entries: 1
number of buckets with 1 entries: 2
number of buckets with 2 entries: 1
number of buckets with 3 entries: 0
number of buckets with 4 entries: 0
number of buckets with 5 entries: 0
number of buckets with 6 entries: 0
number of buckets with 7 entries: 0
number of buckets with 8 entries: 0
number of buckets with 9 entries: 0
number of buckets with 10 or more entries: 0
average search distance for entry: 1.2
.CE
.SH "SEE ALSO"
list(n), string(n), variable(n), trace(n), foreach(n)
.SH KEYWORDS
array, element names, search
|
Changes to doc/bgerror.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: bgerror.n,v 1.4.18.1 2004/10/27 09:35:38 dkf Exp $ '\" .so man.macros .TH bgerror n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME bgerror \- Command invoked to process background errors |
| ︙ | ︙ | |||
67 68 69 70 71 72 73 74 75 76 77 78 79 | be redefined by setting the option database values \fB*ErrorDialog.function.text\fR, to specify the caption for the function button, and \fB*ErrorDialog.function.command\fR, to specify the command to be run. The text of the stack trace is appended to the command when it is evaluated. If either of these options is set to the empty string, then the additional button will not be displayed in the dialog. .SH "SEE ALSO" after(n), tclvars(n) .SH KEYWORDS background error, reporting | > > > > > > > > > > > > > > > > | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
be redefined by setting the option database values
\fB*ErrorDialog.function.text\fR, to specify the caption for the
function button, and \fB*ErrorDialog.function.command\fR, to specify
the command to be run. The text of the stack trace is appended to the
command when it is evaluated. If either of these options is set to
the empty string, then the additional button will not be displayed in
the dialog.
.PP
If you are writing code that will be used by others as part of a
package or other kind of library, consider avoiding \fBbgerror\fR.
The reason for this is that the application programmer may also want
to define a \fBbgerror\fR, or use other code that does and thus will
have trouble integrating your code.
.SH "EXAMPLE"
This \fBbgerror\fR procedure appends errors to a file, with a timestamp.
.CS
proc bgerror {message} {
set timestamp [clock format [clock seconds]]
set fl [open mylog.txt {WRONLY CREAT APPEND}]
puts $fl "$timestamp: bgerror in $::argv '$message'"
close $fl
}
.CE
.SH "SEE ALSO"
after(n), tclvars(n)
.SH KEYWORDS
background error, reporting
|
Changes to doc/binary.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1997 by Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1997 by Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: binary.n,v 1.11.2.8 2005/02/10 10:28:21 dkf Exp $ '\" .so man.macros .TH binary n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME binary \- Insert and extract fields from binary strings |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
.CS
\fBbinary format d3d {1.0 2.0 3.0 4.0} 0.1\fR
.CE
.PP
The first argument is a list of four numbers, but because of the count
of 3 for the associated field specifier, only the first three will be
used. The second argument is associated with the second field
| | > > > > > > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
.CS
\fBbinary format d3d {1.0 2.0 3.0 4.0} 0.1\fR
.CE
.PP
The first argument is a list of four numbers, but because of the count
of 3 for the associated field specifier, only the first three will be
used. The second argument is associated with the second field
specifier. The resulting binary string contains the four numbers 1.0,
2.0, 3.0 and 0.1.
.PP
Each type-count pair moves an imaginary cursor through the binary
data, storing bytes at the current position and advancing the cursor
to just after the last byte stored. The cursor is initially at
position 0 at the beginning of the data. The type may be any one of
the following characters:
.IP \fBa\fR 5
Stores a character string of length \fIcount\fR in the output string.
Every character is taken as modulo 256 (i.e. the low byte of every
character is used, and the high byte discarded) so when storing
character strings not wholly expressible using the characters \\u0000-\\u00ff,
the \fBencoding convertto\fR command should be used
first if this truncation is not desired (i.e. if the characters are
not part of the ISO 8859-1 character set.)
If \fIarg\fR has fewer than \fIcount\fR bytes, then additional zero
bytes are used to pad out the field. If \fIarg\fR is longer than the
specified length, the extra characters will be ignored. If
\fIcount\fR is \fB*\fR, then all of the bytes in \fIarg\fR will be
formatted. If \fIcount\fR is omitted, then one character will be
formatted. For example,
.RS
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
\fBbinary format I3 {3 -3 65536 1}\fR
.CE
will return a string equivalent to
\fB\\x00\\x00\\x00\\x03\\xff\\xff\\xff\\xfd\\x00\\x01\\x00\\x00\fR
.RE
.IP \fBw\fR 5
.VS 8.4
| | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 |
\fBbinary format I3 {3 -3 65536 1}\fR
.CE
will return a string equivalent to
\fB\\x00\\x00\\x00\\x03\\xff\\xff\\xff\\xfd\\x00\\x01\\x00\\x00\fR
.RE
.IP \fBw\fR 5
.VS 8.4
This form is the same as \fBc\fR except that it stores one or more
64-bit integers in little-endian byte order in the output string. The
low-order 64-bits of each integer are stored as an eight-byte value at
the cursor position with the least significant byte stored first. For
example,
.RS
.CS
\fBbinary format w 7810179016327718216\fR
.CE
will return the string \fBHelloTcl\fR
.RE
.IP \fBW\fR 5
This form is the same as \fBw\fR except that it stores one or more one
or more 64-bit integers in big-endian byte order in the output string.
For example,
.RS
.CS
\fBbinary format Wc 4785469626960341345 110\fR
.CE
will return the string \fBBigEndian\fR
.VE
.RE
.IP \fBf\fR 5
This form is the same as \fBc\fR except that it stores one or more one
or more single-precision floating in the machine's native
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 | reading bytes from the current position. The cursor is initially at position 0 at the beginning of the data. The type may be any one of the following characters: .IP \fBa\fR 5 The data is a character string of length \fIcount\fR. If \fIcount\fR is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be scanned into the variable. If \fIcount\fR is omitted, then one | | > > > > | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 | reading bytes from the current position. The cursor is initially at position 0 at the beginning of the data. The type may be any one of the following characters: .IP \fBa\fR 5 The data is a character string of length \fIcount\fR. If \fIcount\fR is \fB*\fR, then all of the remaining bytes in \fIstring\fR will be scanned into the variable. If \fIcount\fR is omitted, then one character will be scanned. All characters scanned will be interpreted as being in the range \\u0000-\\u00ff so the \fBencoding convertfrom\fR command might be needed if the string is not an ISO 8859\-1 string. For example, .RS .CS \fBbinary scan abcde\\000fghi a6a10 var1 var2\fR .CE will return \fB1\fR with the string equivalent to \fBabcde\\000\fR stored in \fBvar1\fR and \fBvar2\fR left unmodified. .RE |
| ︙ | ︙ | |||
462 463 464 465 466 467 468 | \fBbinary scan \\x07\\x86\\x05 c2c* var1 var2\fR .CE will return \fB2\fR with \fB7 -122\fR stored in \fBvar1\fR and \fB5\fR stored in \fBvar2\fR. Note that the integers returned are signed, but they can be converted to unsigned 8-bit quantities using an expression like: .CS | | | | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
\fBbinary scan \\x07\\x86\\x05 c2c* var1 var2\fR
.CE
will return \fB2\fR with \fB7 -122\fR stored in \fBvar1\fR and \fB5\fR
stored in \fBvar2\fR. Note that the integers returned are signed, but
they can be converted to unsigned 8-bit quantities using an expression
like:
.CS
\fBexpr { $num & 0xff }\fR
.CE
.RE
.IP \fBs\fR 5
The data is interpreted as \fIcount\fR 16-bit signed integers
represented in little-endian byte order. The integers are stored in
the corresponding variable as a list. If \fIcount\fR is \fB*\fR, then
all of the remaining bytes in \fBstring\fR will be scanned. If
\fIcount\fR is omitted, then one 16-bit integer will be scanned. For
example,
.RS
.CS
\fBbinary scan \\x05\\x00\\x07\\x00\\xf0\\xff s2s* var1 var2\fR
.CE
will return \fB2\fR with \fB5 7\fR stored in \fBvar1\fR and \fB-16\fR
stored in \fBvar2\fR. Note that the integers returned are signed, but
they can be converted to unsigned 16-bit quantities using an expression
like:
.CS
\fBexpr { $num & 0xffff }\fR
.CE
.RE
.IP \fBS\fR 5
This form is the same as \fBs\fR except that the data is interpreted
as \fIcount\fR 16-bit signed integers represented in big-endian byte
order. For example,
.RS
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 | \fIcount\fR is omitted, then one 32-bit integer will be scanned. For example, .RS .CS \fBbinary scan \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff i2i* var1 var2\fR .CE will return \fB2\fR with \fB5 7\fR stored in \fBvar1\fR and \fB-16\fR | | | > > > > | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 |
\fIcount\fR is omitted, then one 32-bit integer will be scanned. For
example,
.RS
.CS
\fBbinary scan \\x05\\x00\\x00\\x00\\x07\\x00\\x00\\x00\\xf0\\xff\\xff\\xff i2i* var1 var2\fR
.CE
will return \fB2\fR with \fB5 7\fR stored in \fBvar1\fR and \fB-16\fR
stored in \fBvar2\fR. Note that the integers returned are signed, but
they can be converted to unsigned 32-bit quantities using an expression
like:
.CS
\fBexpr { $num & 0xffffffff }\fR
.CE
.RE
.IP \fBI\fR 5
This form is the same as \fBI\fR except that the data is interpreted
as \fIcount\fR 32-bit signed integers represented in big-endian byte
order. For example,
.RS
.CS
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 | .RS .CS \fBbinary scan \\x01\\x02\\x03\\x04 c2@1H* var1 var2\fR .CE will return \fB2\fR with \fB1 2\fR stored in \fBvar1\fR and \fB020304\fR stored in \fBvar2\fR. .RE | < > > > > > > > > > > > > > > > > > > > > > > | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 |
.RS
.CS
\fBbinary scan \\x01\\x02\\x03\\x04 c2@1H* var1 var2\fR
.CE
will return \fB2\fR with \fB1 2\fR stored in \fBvar1\fR and \fB020304\fR
stored in \fBvar2\fR.
.RE
.SH "PLATFORM ISSUES"
Sometimes it is desirable to format or scan integer values in the
native byte order for the machine. Refer to the \fBbyteOrder\fR
element of the \fBtcl_platform\fR array to decide which type character
to use when formatting or scanning integers.
.SH EXAMPLES
This is a procedure to write a Tcl string to a binary-encoded channel as
UTF-8 data preceded by a length word:
.CS
proc writeString {channel string} {
set data [encoding convertto utf-8 $string]
puts -nonewline [\fBbinary format\fR Ia* \e
[string length $data] $data]
}
.CE
.PP
This procedure reads a string from a channel that was written by the
previously presented \fBwriteString\fR procedure:
.CS
proc readString {channel} {
if {![\fBbinary scan\fR [read $channel 4] I length]} {
error "missing length"
}
set data [read $channel $length]
return [encoding convertfrom utf-8 $data]
}
.CE
.SH "SEE ALSO"
format(n), scan(n), tclvars(n)
.SH KEYWORDS
binary, format, scan
|
Changes to doc/break.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | > > > > > > | > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
'\"
'\" Copyright (c) 1993-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: break.n,v 1.3.18.1 2004/10/27 09:35:38 dkf Exp $
'\"
.so man.macros
.TH break n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
break \- Abort looping command
.SH SYNOPSIS
\fBbreak\fR
.BE
.SH DESCRIPTION
.PP
This command is typically invoked inside the body of a looping command
such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR.
It returns a \fBTCL_BREAK\fR code, which causes a break exception
to occur.
The exception causes the current script to be aborted
out to the innermost containing loop command, which then
aborts its execution and returns normally.
Break exceptions are also handled in a few other situations, such
as the \fBcatch\fR command, Tk event bindings, and the outermost
scripts of procedure bodies.
.SH EXAMPLE
Print a line for each of the integers from 0 to 5:
.CS
for {set x 0} {$x<10} {incr x} {
if {$x > 5} {
\fBbreak\fR
}
puts "x is $x"
}
.CE
.SH "SEE ALSO"
catch(n), continue(n), for(n), foreach(n), return(n), while(n)
.SH KEYWORDS
abort, break, loop
|
Changes to doc/catch.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | > > > > > > > > | > > | > > > | | < < | > < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
'\"
'\" Copyright (c) 1993-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: catch.n,v 1.5.18.2 2004/11/09 10:25:23 dkf Exp $
'\"
.so man.macros
.TH catch n "8.0" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
catch \- Evaluate script and trap exceptional returns
.SH SYNOPSIS
\fBcatch\fI script \fR?\fIvarName\fR?
.BE
.SH DESCRIPTION
.PP
The \fBcatch\fR command may be used to prevent errors from aborting command
interpretation. The \fBcatch\fR command calls the Tcl interpreter recursively to
execute \fIscript\fR, and always returns without raising an error,
regardless of any errors that might occur while executing \fIscript\fR.
.PP
If \fIscript\fR raises an error, \fBcatch\fR will return a non-zero integer
value corresponding to the exceptional return code returned by evaluation
of \fIscript\fR. Tcl defines the normal return code from script
evaluation to be zero (0), or \fBTCL_OK\fR. Tcl also defines four exceptional
return codes: 1 (\fBTCL_ERROR\fR), 2 (\fBTCL_RETURN\fR), 3 (\fBTCL_BREAK\fR),
and 4 (\fBTCL_CONTINUE\fR). Errors during evaluation of a script are indicated
by a return code of \fBTCL_ERROR\fR. The other exceptional return codes are
returned by the \fBreturn\fR, \fBbreak\fR, and \fBcontinue\fR commands
and in other special situations as documented. Tcl packages can define
new commands that return other integer values as return codes as well,
and scripts that make use of the \fBreturn -code\fR command can also
have return codes other than the five defined by Tcl.
.PP
If the \fIvarName\fR argument is given, then the variable it names is
set to the result of the script evaluation. When the return code from
the script is 1 (\fBTCL_ERROR\fR), the value stored in \fIvarName\fR is an error
message. When the return code from the script is 0 (\fBTCL_OK\fR), the value
stored in \fIresultVarName\fR is the value returned from \fIscript\fR.
.PP
If \fIscript\fR does not raise an error, \fBcatch\fR will return 0
(\fBTCL_OK\fR) and set the variable to the value returned from \fIscript\fR.
.PP
Note that \fBcatch\fR catches all exceptions, including those
generated by \fBbreak\fR and \fBcontinue\fR as well as errors. The
only errors that are not caught are syntax errors found when the
script is compiled. This is because the catch command only catches
errors during runtime. When the catch statement is compiled, the
script is compiled as well and any syntax errors will generate a Tcl
error.
.SH EXAMPLES
The \fBcatch\fR command may be used in an \fBif\fR to branch based on
the success of a script.
.CS
if { [\fBcatch\fR {open $someFile w} fid] } {
puts stderr "Could not open $someFile for writing\\n$fid"
exit 1
}
.CE
.PP
The \fBcatch\fR command will not catch compiled syntax errors. The
first time proc \fBfoo\fR is called, the body will be compiled and a
Tcl error will be generated.
.CS
proc foo {} {
\fBcatch\fR {expr {1 +- }}
}
.CE
.SH "SEE ALSO"
break(n), continue(n), error(n), return(n), tclvars(n)
.SH KEYWORDS
catch, error
|
Changes to doc/cd.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: cd.n,v 1.3.18.1 2004/10/27 09:35:38 dkf Exp $ '\" .so man.macros .TH cd n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME cd \- Change working directory .SH SYNOPSIS \fBcd \fR?\fIdirName\fR? .BE .SH DESCRIPTION .PP Change the current working directory to \fIdirName\fR, or to the home directory (as specified in the HOME environment variable) if \fIdirName\fR is not given. Returns an empty string. Note that the current working directory is a per-process resource; the \fBcd\fR command changes the working directory for all interpreters and (in a threaded environment) all threads. .SH EXAMPLES Change to the home directory of the user \fBfred\fR: .CS \fBcd\fR ~fred .CE .PP Change to the directory \fBlib\fR that is a sibling directory of the current one: .CS \fBcd\fR ../lib .CE .SH "SEE ALSO" filename(n), glob(n), pwd(n) .SH KEYWORDS working directory |
Changes to doc/clock.n.
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 2002 ActiveState Corporation '\" '\" This documentation is derived from the time and date facilities of '\" TclX, by Mark Diekhans and Karl Lehenbauer. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | '\" '\" Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 2002 ActiveState Corporation '\" '\" This documentation is derived from the time and date facilities of '\" TclX, by Mark Diekhans and Karl Lehenbauer. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: clock.n,v 1.11.2.6 2004/12/13 15:52:21 kennykb Exp $ '\" .so man.macros .TH clock n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME clock \- Obtain and manipulate time .SH SYNOPSIS \fBclock \fIoption\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command performs one of several operations that may obtain or manipulate strings or values that represent some notion of time. The \fIoption\fR argument determines what action is carried out by the command. The legal \fIoptions\fR (which may be abbreviated) are: .VS 8.3 .TP \fBclock clicks\fR ?\fB\-milliseconds\fR? Return a high-resolution time value as a system-dependent integer value. The unit of the value is system-dependent but should be the highest resolution clock available on the system such as a CPU cycle counter. If \fB\-milliseconds\fR is specified, then the value is guaranteed to be of millisecond granularity. This value should only be used for the relative measurement of elapsed time. .VE 8.3 .TP \fBclock format \fIclockValue\fR ?\fB\-format \fIstring\fR? ?\fB\-gmt \fIboolean\fR? Converts an integer time value, typically returned by \fBclock seconds\fR, \fBclock scan\fR, or the \fBatime\fR or \fBmtime\fR options of the \fBfile\fR command, to human-readable form. If the \fB\-format\fR argument is present the next argument is a string that describes how the date and time are to be formatted. Field descriptors consist of a \fB%\fR followed by a field descriptor character. All other characters are copied into the result. Valid field descriptors are: .RS .IP \fB%%\fR |
| ︙ | ︙ | |||
75 76 77 78 79 80 81 82 83 84 85 86 87 88 | .VS 8.4 '\" Since the inclusion of compat/strftime.c, %D, %e, %h should work on all '\" platforms. .IP \fB%D\fR Date as %m/%d/%y. .IP \fB%e\fR Day of month (1 - 31), no leading zeros. .IP \fB%h\fR Abbreviated month name. .VE 8.4 .IP \fB%H\fR Hour in 24-hour format (00 - 23). .VS 8.4 .IP \fB%I\fR | > > > > > > | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | .VS 8.4 '\" Since the inclusion of compat/strftime.c, %D, %e, %h should work on all '\" platforms. .IP \fB%D\fR Date as %m/%d/%y. .IP \fB%e\fR Day of month (1 - 31), no leading zeros. .IP \fB%g\fR The ISO8601 year number corresponding to the ISO8601 week (%V), expressed as a two-digit year-of-the-century, with leading zero if necessary. .IP \fB%G\fR The ISO8601 year number corresponding to the ISO8601 week (%V), expressed as a four-digit number. .IP \fB%h\fR Abbreviated month name. .VE 8.4 .IP \fB%H\fR Hour in 24-hour format (00 - 23). .VS 8.4 .IP \fB%I\fR |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .VE .TP \fIISO 8601 point-in-time\fR An ISO 8601 point-in-time specification, such as \fICCyymmddThhmmss\fR, where T is the literal T, \fICCyymmdd hhmmss\fR, or | | > > > > | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | as 1969-1999. Not all platforms can represent the years 38-70, so an error may result if these years are used. .VE .TP \fIISO 8601 point-in-time\fR An ISO 8601 point-in-time specification, such as \fICCyymmddThhmmss\fR, where T is the literal T, \fICCyymmdd hhmmss\fR, or \fICCyymmddThh:mm:ss\fR. Note that only these three formats are accepted. The command does \fInot\fR accept the full range of point-in-time specifications specified in ISO8601. Other formats can be recognized by using commands such as \fBregexp\fR to extract their fields and reorganize them into a form accepted by the \fBclock scan\fR command. .TP \fIrelative time\fR A specification relative to the current time. The format is \fInumber unit\fR acceptable units are \fByear\fR, \fBfortnight\fR, \fBmonth\fR, \fBweek\fR, \fBday\fR, \fBhour\fR, \fBminute\fR (or \fBmin\fR), and \fBsecond\fR (or \fBsec\fR). The unit can be specified as a singular or plural, as in \fB3 weeks\fR. These modifiers may also be specified: |
| ︙ | ︙ | |||
258 259 260 261 262 263 264 | Daylight savings time correction is applied only when the relative time is specified in units of days or more, ie, days, weeks, fortnights, months or years. This means that when crossing the daylight savings time boundary, different results will be given for \fBclock scan "1 day"\fR and \fBclock scan "24 hours"\fR: .CS .ta 6c | | | | | 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | Daylight savings time correction is applied only when the relative time is specified in units of days or more, ie, days, weeks, fortnights, months or years. This means that when crossing the daylight savings time boundary, different results will be given for \fBclock scan "1 day"\fR and \fBclock scan "24 hours"\fR: .CS .ta 6c % \fBclock scan\fR "1 day" -base [\fBclock scan\fR 1999-10-31] 941443200 % \fBclock scan\fR "24 hours" -base [\fBclock scan\fR 1999-10-31] 941439600 .CE .RE .TP \fBclock seconds\fR Return the current date and time as a system-dependent integer value. The unit of the value is seconds, allowing it to be used for relative time calculations. The value is usually defined as total elapsed time from |
| ︙ | ︙ |
Changes to doc/close.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: close.n,v 1.4.8.1 2004/10/27 09:35:38 dkf Exp $ '\" .so man.macros .TH close n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME close \- Close an open channel. |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | .PP Channels are automatically closed when an interpreter is destroyed and when the process exits. Channels are switched to blocking mode, to ensure that all output is correctly flushed before the process exits. .VE .PP The command returns an empty string, and may generate an error if | | > > > > > > > > > > > > > > > > > | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
.PP
Channels are automatically closed when an interpreter is destroyed and
when the process exits. Channels are switched to blocking mode, to ensure
that all output is correctly flushed before the process exits.
.VE
.PP
The command returns an empty string, and may generate an error if
an error occurs while flushing output. If a command in a command
pipeline created with \fBopen\fR returns an error, \fBclose\fR
generates an error (similar to the \fBexec\fR command.)
.SH EXAMPLE
This illustrates how you can use Tcl to ensure that files get closed
even when errors happen by combining \fBcatch\fR, \fBclose\fR and
\fBreturn\fR:
.CS
proc withOpenFile {filename channelVar script} {
upvar 1 $channelVar chan
set chan [open $filename]
catch {
uplevel 1 $script
} result options
\fBclose\fR $chan
return -options $options $result
}
.CE
.SH "SEE ALSO"
file(n), open(n), socket(n), eof(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, channel, close, nonblocking
|
Changes to doc/concat.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | > > > | < < | < | | | > > > | < < > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: concat.n,v 1.4.2.1 2004/10/27 09:35:38 dkf Exp $
'\"
.so man.macros
.TH concat n 8.3 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
concat \- Join lists together
.SH SYNOPSIS
\fBconcat\fI \fR?\fIarg arg ...\fR?
.BE
.SH DESCRIPTION
.PP
This command joins each of its arguments together with spaces after
trimming leading and trailing white-space from each of them. If all the
arguments are lists, this has the same effect as concatenating them
into a single list.
It permits any number of arguments;
if no \fIarg\fRs are supplied, the result is an empty string.
.SH EXAMPLES
Although \fBconcat\fR will concatenate lists (so the command:
.CS
\fBconcat\fR a b {c d e} {f {g h}}
.CE
will return "\fBa b c d e f {g h}\fR" as its result), it will also
concatenate things that are not lists, and hence the command:
.CS
\fBconcat\fR " a b {c " d " e} f"
.CE
will return "\fBa b {c d e} f\fR" as its result.
.PP
Note that the concatenation does not remove spaces from the middle of
its arguments, so the command:
.CS
\fBconcat\fR "a b c" { d e f }
.CE
will return "\fBa b c d e f\fR" (i.e. with three spaces between
the \fBa\fR, the \fBb\fR and the \fBc\fR).
.SH "SEE ALSO"
append(n), eval(n)
.SH KEYWORDS
concatenate, join, lists
|
Changes to doc/continue.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993-1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | > > > > > > | > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
'\"
'\" Copyright (c) 1993-1994 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: continue.n,v 1.3.18.1 2004/10/27 09:35:38 dkf Exp $
'\"
.so man.macros
.TH continue n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
continue \- Skip to the next iteration of a loop
.SH SYNOPSIS
\fBcontinue\fR
.BE
.SH DESCRIPTION
.PP
This command is typically invoked inside the body of a looping command
such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR.
It returns a \fBTCL_CONTINUE\fR code, which causes a continue exception
to occur.
The exception causes the current script to be aborted
out to the innermost containing loop command, which then
continues with the next iteration of the loop.
Catch exceptions are also handled in a few other situations, such
as the \fBcatch\fR command and the outermost scripts of procedure
bodies.
.SH EXAMPLE
Print a line for each of the integers from 0 to 10 \fIexcept\fR 5:
.CS
for {set x 0} {$x<10} {incr x} {
if {$x == 5} {
\fBcontinue\fR
}
puts "x is $x"
}
.CE
.SH "SEE ALSO"
break(n), for(n), foreach(n), return(n), while(n)
.SH KEYWORDS
continue, iteration, loop
|
Changes to doc/dde.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2001 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | | | | | < | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
'\"
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2001 ActiveState Corporation.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: dde.n,v 1.8.2.4 2004/12/03 00:37:21 hobbs Exp $
'\"
.so man.macros
.TH dde n 1.2 dde "Tcl Bundled Packages"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
dde \- Execute a Dynamic Data Exchange command
.SH SYNOPSIS
.sp
\fBpackage require dde 1.2\fR
.sp
\fBdde eval\fR ?\fB\-async\fR? \fIservice cmd\fR ?\fIarg ...\fR?
.sp
\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR
.sp
\fBdde poke \fIservice topic item data\fR
.sp
\fBdde request\fR ?\fB\-binary\fR? \fIservice topic data\fR
.sp
\fBdde servername\fR ?\fItopic\fR?
.sp
\fBdde services \fIservice topic\fR
.BE
.SH DESCRIPTION
.PP
This command allows an application to send Dynamic Data Exchange (DDE)
command when running under Microsoft Windows. Dynamic Data Exchange is
a mechanism where applications can exchange raw data. Each DDE
transaction needs a \fIservice name\fR and a \fItopic\fR. Both the
\fIservice name\fR and \fItopic\fR are application defined; Tcl uses
the service name \fBTclEval\fR, while the topic name is the name of the
interpreter given by \fBdde servername\fR. Other applications have their
own \fIservice name\fRs and \fItopic\fRs. For instance, Microsoft Excel
has the service name \fBExcel\fR.
.PP
The \fBeval\fR and \fBexecute\fR commands accept the option \fB\-async\fR:
.SH "DDE COMMANDS"
.PP
The following commands are a subset of the full Dynamic Data Exchange
set of commands.
.TP
\fBdde servername \fR?\fItopic\fR?
\fBdde servername\fR registers the interpreter as a DDE server with
the service name \fBTclEval\fR and the topic name specified by \fItopic\fR.
If no \fItopic\fR is given, \fBdde servername\fR returns the name
of the current topic or the empty string if it is not registered as a service.
.TP
\fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR
\fBdde execute\fR takes the \fIdata\fR and sends it to the server indicated
by \fIservice\fR with the topic indicated by \fItopic\fR. Typically,
\fIservice\fR is the name of an application, and \fItopic\fR is a file to
work on. The \fIdata\fR field is given to the remote application.
Typically, the application treats the \fIdata\fR field as a script, and the
script is run in the application. The \fB\-async\fR option requests
asynchronous invocation. The command returns an error message if the
script did not run, unless the \fB\-async\fR flag was used, in which case
the command returns immediately with no error.
.TP
\fBdde poke \fIservice topic item data\fR
\fBdde poke\fR passes the \fIdata\fR to the server indicated by
\fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically,
\fIservice\fR is the name of an application. \fItopic\fR is application
specific but can be a command to the server or the name of a file to work
on. The \fIitem\fR is also application specific and is often not used, but
it must always be non-null. The \fIdata\fR field is given to the remote
application.
.TP
\fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR
\fBdde request\fR is typically used to get the value of something; the
value of a cell in Microsoft Excel or the text of a selection in
Microsoft Word. \fIservice\fR is typically the name of an application,
\fItopic\fR is typically the name of the file, and \fIitem\fR is
application-specific. The command returns the value of \fIitem\fR as
defined in the application. Normally this is interpreted to be a
string with terminating null. If \fB\-binary\fR is specified, the
result is returned as a byte array.
.TP
\fBdde services \fIservice topic\fR
\fBdde services\fR returns a list of service-topic pairs that
currently exist on the machine. If \fIservice\fR and \fItopic\fR are
both null strings ({}), then all service-topic pairs currently
available on the system are returned. If \fIservice\fR is null and
\fItopic\fR is not, then all services with the specified topic are
returned. If \fIservice\fR is not null and \fItopic\fR is, all topics
for a given service are returned. If both are not null, if that
service-topic pair currently exists, it is returned; otherwise, null
is returned.
.TP
\fBdde eval\fR ?\fB\-async\fR? \fItopic cmd \fR?\fIarg arg ...\fR?
\fBdde eval\fR evaluates a command and its arguments using the interpreter
specified by \fItopic\fR. The DDE service must be the \fBTclEval\fR
service. The \fB\-async\fR option requests asynchronous invocation. The
command returns an error message if the script did not run, unless the
\fB\-async\fR flag was used, in which case the command returns immediately
with no error. This command can be used to replace \fBsend\fR on Windows.
.SH "DDE AND TCL"
A Tcl interpreter always has a service name of \fBTclEval\fR. Each
different interpreter of all running Tcl applications must be
given a unique
name specified by \fBdde servername\fR. Each interp is available as a
DDE topic only if the \fBdde servername\fR command was used to set the
|
| ︙ | ︙ | |||
133 134 135 136 137 138 139 140 141 142 143 144 145 | When using DDE, be careful to ensure that the event queue is flushed using either \fBupdate\fR or \fBvwait\fR. This happens by default when using \fBwish\fR unless a blocking command is called (such as \fBexec\fR without adding the \fB&\fR to place the process in the background). If for any reason the event queue is not flushed, DDE commands may hang until the event queue is flushed. This can create a deadlock situation. .SH "SEE ALSO" tk(n), winfo(n), send(n) .SH KEYWORDS application, dde, name, remote execution | > > > > > > > > | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | When using DDE, be careful to ensure that the event queue is flushed using either \fBupdate\fR or \fBvwait\fR. This happens by default when using \fBwish\fR unless a blocking command is called (such as \fBexec\fR without adding the \fB&\fR to place the process in the background). If for any reason the event queue is not flushed, DDE commands may hang until the event queue is flushed. This can create a deadlock situation. .SH EXAMPLE This asks Internet Explorer (which must already be running) to go to a particularly important website: .CS package require dde \fBdde execute\fR iexplore WWW_OpenURL http://www.tcl.tk/ .CE .SH "SEE ALSO" tk(n), winfo(n), send(n) .SH KEYWORDS application, dde, name, remote execution |
Changes to doc/encoding.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1998 by Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < | | < > > > > | | | < | | | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | '\" '\" Copyright (c) 1998 by Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: encoding.n,v 1.3.18.3 2004/10/27 14:23:56 dkf Exp $ '\" .so man.macros .TH encoding n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME encoding \- Manipulate encodings .SH SYNOPSIS \fBencoding \fIoption\fR ?\fIarg arg ...\fR? .BE .SH INTRODUCTION .PP Strings in Tcl are encoded using 16-bit Unicode characters. Different operating system interfaces or applications may generate strings in other encodings such as Shift-JIS. The \fBencoding\fR command helps to bridge the gap between Unicode and these other formats. .SH DESCRIPTION .PP Performs one of several encoding related operations, depending on \fIoption\fR. The legal \fIoption\fRs are: .TP \fBencoding convertfrom\fR ?\fIencoding\fR? \fIdata\fR Convert \fIdata\fR to Unicode from the specified \fIencoding\fR. The characters in \fIdata\fR are treated as binary data where the lower 8-bits of each character is taken as a single byte. The resulting sequence of bytes is treated as a string in the specified \fIencoding\fR. If \fIencoding\fR is not specified, the current system encoding is used. .TP \fBencoding convertto\fR ?\fIencoding\fR? \fIstring\fR Convert \fIstring\fR from Unicode to the specified \fIencoding\fR. The result is a sequence of bytes that represents the converted string. Each byte is stored in the lower 8-bits of a Unicode character. If \fIencoding\fR is not specified, the current system encoding is used. .TP \fBencoding names\fR Returns a list containing the names of all of the encodings that are currently available. .TP \fBencoding system\fR ?\fIencoding\fR? Set the system encoding to \fIencoding\fR. If \fIencoding\fR is omitted then the command returns the current system encoding. The system encoding is used whenever Tcl passes strings to system calls. .SH EXAMPLE .PP It is common practice to write script files using a text editor that produces output in the euc-jp encoding, which represents the ASCII characters as singe bytes and Japanese characters as two bytes. This makes it easy to embed literal strings that correspond to non-ASCII characters by simply typing the strings in place in the script. However, because the \fBsource\fR command always reads files using the current system encoding, Tcl will only source such files correctly when the encoding used to write the file is the same. This tends not to be true in an internationalized setting. For example, if such a file was sourced in North America (where the ISO8859-1 is normally used), each byte in the file would be treated as a separate character that maps to the 00 page in Unicode. The resulting Tcl strings will not contain the expected Japanese characters. Instead, they will contain a sequence of Latin-1 characters that correspond to the bytes of the original string. The \fBencoding\fR command can be used to convert this string to the expected Japanese Unicode characters. For example, .CS set s [\fBencoding convertfrom\fR euc-jp "\\xA4\\xCF"] .CE would return the Unicode string "\\u306F", which is the Hiragana letter HA. .SH "SEE ALSO" Tcl_GetEncoding(3) .SH KEYWORDS encoding |
Changes to doc/eof.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < > > | > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: eof.n,v 1.4.8.1 2004/10/27 09:35:38 dkf Exp $
'\"
.so man.macros
.TH eof n 7.5 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
eof \- Check for end of file condition on channel
.SH SYNOPSIS
\fBeof \fIchannelId\fR
.BE
.SH DESCRIPTION
.PP
Returns 1 if an end of file condition occurred during the most
recent input operation on \fIchannelId\fR (such as \fBgets\fR),
0 otherwise.
.PP
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.SH EXAMPLES
Read and print out the contents of a file line-by-line:
.CS
set f [open somefile.txt]
while {1} {
set line [gets $f]
if {[\fBeof\fR $f]} {
close $f
break
}
puts "Read line: $line"
}
.CE
.PP
Read and print out the contents of a file by fixed-size records:
.CS
set f [open somefile.dat]
fconfigure $f -translation binary
set recordSize 40
while {1} {
set record [read $f $recordSize]
if {[\fBeof\fR $f]} {
close $f
break
}
puts "Read record: $record"
}
.CE
.SH "SEE ALSO"
file(n), open(n), close(n), fblocked(n), Tcl_StandardChannels(3)
.SH KEYWORDS
channel, end of file
|
Changes to doc/error.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: error.n,v 1.3.18.1 2004/10/27 09:35:38 dkf Exp $ '\" .so man.macros .TH error n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME error \- Generate an error .SH SYNOPSIS \fBerror \fImessage\fR ?\fIinfo\fR? ?\fIcode\fR? .BE .SH DESCRIPTION .PP Returns a \fBTCL_ERROR\fR code, which causes command interpretation to be unwound. \fIMessage\fR is a string that is returned to the application to indicate what went wrong. .PP If the \fIinfo\fR argument is provided and is non-empty, it is used to initialize the global variable \fBerrorInfo\fR. \fBerrorInfo\fR is used to accumulate a stack trace of what was in progress when an error occurred; as nested commands unwind, |
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | to hold a machine-readable description of the error in cases where such information is available; see the \fBtclvars\fR manual page for information on the proper format for the variable. If the \fIcode\fR argument is not present, then \fBerrorCode\fR is automatically reset to ``NONE'' by the Tcl interpreter as part of processing the error generated by the command. | > > > > > | > > | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
to hold a machine-readable description of the error in cases where
such information is available; see the \fBtclvars\fR manual
page for information on the proper format for the variable.
If the \fIcode\fR argument is not
present, then \fBerrorCode\fR is automatically reset to
``NONE'' by the Tcl interpreter as part of processing the
error generated by the command.
.SH EXAMPLE
Generate an error if a basic mathematical operation fails:
.CS
if {1+2 != 3} {
\fBerror\fR "something is very wrong with addition"
}
.CE
.SH "SEE ALSO"
catch(n), return(n), tclvars(n)
.SH KEYWORDS
error, errorCode, errorInfo
|
Changes to doc/eval.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: eval.n,v 1.4.2.1 2004/10/27 09:35:38 dkf Exp $ '\" .so man.macros .TH eval n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME eval \- Evaluate a Tcl script |
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 | script containing one or more commands. \fBEval\fR concatenates all its arguments in the same fashion as the \fBconcat\fR command, passes the concatenated string to the Tcl interpreter recursively, and returns the result of that evaluation (or any error generated by it). Note that the \fBlist\fR command quotes sequences of words in such a way that they are not further expanded by the \fBeval\fR command. .SH KEYWORDS concatenate, evaluate, script .SH "SEE ALSO" catch(n), concat(n), error(n), list(n), subst(n), tclvars(n) | > > > > > > > > > > > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
script containing one or more commands.
\fBEval\fR concatenates all its arguments in the same
fashion as the \fBconcat\fR command, passes the concatenated string to the
Tcl interpreter recursively, and returns the result of that
evaluation (or any error generated by it).
Note that the \fBlist\fR command quotes sequences of words in such a
way that they are not further expanded by the \fBeval\fR command.
.SH EXAMPLE
This procedure acts in a way that is analogous to the \fBlappend\fR
command, except it inserts the argument values at the start of the
list in the variable:
.CS
proc lprepend {varName args} {
upvar 1 $varName var
# Ensure that the variable exists and contains a list
lappend var
# Now we insert all the arguments in one go
set var [\fBeval\fR [list linsert $var 0] $args]
}
.CE
.SH KEYWORDS
concatenate, evaluate, script
.SH "SEE ALSO"
catch(n), concat(n), error(n), list(n), subst(n), tclvars(n)
|
Changes to doc/exec.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: exec.n,v 1.6.2.1 2004/10/27 09:35:38 dkf Exp $ '\" .so man.macros .TH exec n 7.6 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME exec \- Invoke subprocesses .SH SYNOPSIS \fBexec \fR?\fIswitches\fR? \fIarg \fR?\fIarg ...\fR? .BE .SH DESCRIPTION .PP This command treats its arguments as the specification |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | Retains a trailing newline in the pipeline's output. Normally a trailing newline will be deleted. .TP 13 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as the first \fIarg\fR even if it starts with a \fB\-\fR. .PP | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | Retains a trailing newline in the pipeline's output. Normally a trailing newline will be deleted. .TP 13 \fB\-\|\-\fR Marks the end of switches. The argument following this one will be treated as the first \fIarg\fR even if it starts with a \fB\-\fR. .PP If an \fIarg\fR (or pair of \fIarg\fRs) has one of the forms described below then it is used by \fBexec\fR to control the flow of input and output among the subprocess(es). Such arguments will not be passed to the subprocess(es). In forms such as ``< \fIfileName\fR'' \fIfileName\fR may either be in a separate argument from ``<'' or in the same argument with no intervening space (i.e. ``<\fIfileName\fR''). .TP 15 |
| ︙ | ︙ | |||
213 214 215 216 217 218 219 | Note that there are two general types of Win32 console applications: .RS 1) CLI -- CommandLine Interface, simple stdio exchange. \fBnetstat.exe\fR for example. .br 2) TUI -- Textmode User Interface, any application that accesses the console API for doing such things as cursor movement, setting text color, detecting | | | < | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 | Note that there are two general types of Win32 console applications: .RS 1) CLI -- CommandLine Interface, simple stdio exchange. \fBnetstat.exe\fR for example. .br 2) TUI -- Textmode User Interface, any application that accesses the console API for doing such things as cursor movement, setting text color, detecting key presses and mouse movement, etc. An example would be \fBtelnet.exe\fR from Windows 2000. These types of applications are not common in a windows environment, but do exist. .RE \fBexec\fR will not work well with TUI applications when a console is not present, as is done when launching applications under wish. It is desirable to have console applications hidden and detached. This is a designed-in limitation as \fBexec\fR wants to communicate over pipes. The Expect extension addresses this issue when communicating with a TUI application. .sp .RE .TP \fBWindows NT\fR . When attempting to execute an application, \fBexec\fR first searches for the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and |
| ︙ | ︙ | |||
250 251 252 253 254 255 256 | The Windows NT 16-bit system directory. .br The Windows NT home directory. .br The directories listed in the path. .RE .sp | | | > | | | | | > | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 | The Windows NT 16-bit system directory. .br The Windows NT home directory. .br The directories listed in the path. .RE .sp In order to execute shell built-in commands like \fBdir\fR and \fBcopy\fR, the caller must prepend the desired command with ``\fBcmd.exe /c\0\fR'' because built-in commands are not implemented using executables. .sp .RE .TP \fBWindows 9x\fR . When attempting to execute an application, \fBexec\fR first searches for the name as it was specified. Then, in order, \fB.com\fR, \fB.exe\fR, and \fB.bat\fR are appended to the end of the specified name and it searches for the longer name. If a directory name was not specified as part of the application name, the following directories are automatically searched in order when attempting to locate the application: .sp .RS .RS The directory from which the Tcl executable was loaded. .br The current directory. .br The Windows 9x system directory. .br The Windows 9x home directory. .br The directories listed in the path. .RE .sp In order to execute shell built-in commands like \fBdir\fR and \fBcopy\fR, the caller must prepend the desired command with ``\fBcommand.com /c\0\fR'' because built-in commands are not implemented using executables. .sp Once a 16-bit DOS application has read standard input from a console and then quit, all subsequently run 16-bit DOS applications will see the standard input as already closed. 32-bit applications do not have this problem and will run correctly, even after a 16-bit DOS application thinks that standard input is closed. There is no known workaround for this bug at this time. |
| ︙ | ︙ | |||
317 318 319 320 321 322 323 324 325 326 327 328 329 | .RE .TP \fBMacintosh\fR The \fBexec\fR command is not implemented and does not exist under Macintosh. .TP \fBUnix\fR\0\0\0\0\0\0\0 The \fBexec\fR command is fully functional and works as described. .SH "SEE ALSO" error(n), open(n) .SH KEYWORDS execute, pipeline, redirection, subprocess | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
.RE
.TP
\fBMacintosh\fR
The \fBexec\fR command is not implemented and does not exist under Macintosh.
.TP
\fBUnix\fR\0\0\0\0\0\0\0
The \fBexec\fR command is fully functional and works as described.
.SH "UNIX EXAMPLES"
Here are some examples of the use of the \fBexec\fR command on Unix.
.PP
To execute a simple program and get its result:
.CS
\fBexec\fR uname -a
.CE
.PP
To execute a program that can return a non-zero result, you should
wrap the call to \fBexec\fR in \fBcatch\fR and check what the contents
of the global \fBerrorCode\fR variable is if you have an error:
.CS
set status 0
if {[catch {\fBexec\fR grep foo bar.txt} results]} {
if {[lindex $::errorCode 0] eq "CHILDSTATUS"} {
set status [lindex $::errorCode 2]
} else {
# Some kind of unexpected failure
}
}
.CE
.PP
When translating a command from a Unix shell invocation, care should
be taken over the fact that single quote characters have no special
significance to Tcl. Thus:
.CS
awk '{sum += $1} END {print sum}' numbers.list
.CE
would be translated into something like:
.CS
\fBexec\fR awk {{sum += $1} END {print sum}} numbers.list
.CE
.PP
If you are converting invocations involving shell globbing, you should
remember that Tcl does not handle globbing or expand things into
multiple arguments by default. Instead you should write things like
this:
.CS
eval [list \fBexec\fR ls -l] [glob *.tcl]
.CE
.PP
.SH "WINDOWS EXAMPLES"
Here are some examples of the use of the \fBexec\fR command on Windows.
.PP
To start an instance of \fInotepad\fR editing a file without waiting
for the user to finish editing the file:
.CS
\fBexec\fR notepad myfile.txt &
.CE
.PP
To print a text file using \fInotepad\fR:
.CS
\fBexec\fR notepad /p myfile.txt
.CE
.PP
If a program calls other programs, such as is common with compilers,
then you may need to resort to batch files to hide the console windows
that sometimes pop up:
.CS
\fBexec\fR cmp.bat somefile.c -o somefile
.CE
With the file \fIcmp.bat\fR looking something like:
.CS
@gcc %1 %2 %3 %4 %5 %6 %7 %8 %9
.CE
.PP
Sometimes you need to be careful, as different programs may have the
same name and be in the path. It can then happen that typing a command
at the DOS prompt finds \fIa different program\fR than the same
command run via \fBexec\fR. This is because of the (documented)
differences in behaviour between \fBexec\fR and DOS batch files.
.PP
When in doubt, use the command \fBauto_execok\fR: it will return the
complete path to the program as seen by the \fBexec\fR command. This
applies especially when you want to run "internal" commands like
\fIdir\fR from a Tcl script (if you just want to list filenames, use
the \fBglob\fR command.) To do that, use this:
.CS
eval [list \fBexec\fR] [auto_execok dir] [list *.tcl]
.CE
.SH "SEE ALSO"
error(n), open(n)
.SH KEYWORDS
execute, pipeline, redirection, subprocess
|
Changes to doc/exit.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: exit.n,v 1.3.18.1 2004/10/27 09:35:38 dkf Exp $
'\"
.so man.macros
.TH exit n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
exit \- End the application
.SH SYNOPSIS
\fBexit \fR?\fIreturnCode\fR?
.BE
.SH DESCRIPTION
.PP
Terminate the process, returning \fIreturnCode\fR to the
system as the exit status.
If \fIreturnCode\fR isn't specified then it defaults
to 0.
.SH EXAMPLE
Since non-zero exit codes are usually interpreted as error cases by
the calling process, the \fBexit\fR command is an important part of
signalling that something fatal has gone wrong. This code fragment is
useful in scripts to act as a general problem trap:
.CS
proc main {} {
# ... put the real main code in here ...
}
if {[catch {main} msg]} {
puts stderr "unexpected script error: $msg"
if {[info exist env(DEBUG)]} {
puts stderr "---- BEGIN TRACE ----"
puts stderr $errorInfo
puts stderr "---- END TRACE ----"
}
# Reserve code 1 for "expected" error exits...
\fBexit\fR 2
}
.CE
.SH "SEE ALSO"
exec(n), tclvars(n)
.SH KEYWORDS
exit, process
|
Changes to doc/expr.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-2000 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: expr.n,v 1.10.2.2 2004/10/27 09:35:38 dkf Exp $ '\" .so man.macros .TH expr n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME expr \- Evaluate an expression .SH SYNOPSIS \fBexpr \fIarg \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP Concatenates \fIarg\fRs (adding separator spaces between them), evaluates the result as a Tcl expression, and returns the value. The operators permitted in Tcl expressions are a subset of the operators permitted in C expressions, and they have the same meaning and precedence as the corresponding C operators. Expressions almost always yield numeric results (integer or floating-point values). For example, the expression |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 | If an operand does not have one of the integer formats given above, then it is treated as a floating-point number if that is possible. Floating-point numbers may be specified in any of the ways accepted by an ANSI-compliant C compiler (except that the \fBf\fR, \fBF\fR, \fBl\fR, and \fBL\fR suffixes will not be permitted in most installations). For example, all of the following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16. | | > > | < | > > | | | | | < | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | If an operand does not have one of the integer formats given above, then it is treated as a floating-point number if that is possible. Floating-point numbers may be specified in any of the ways accepted by an ANSI-compliant C compiler (except that the \fBf\fR, \fBF\fR, \fBl\fR, and \fBL\fR suffixes will not be permitted in most installations). For example, all of the following are valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16. If no numeric interpretation is possible (note that all literal operands that are not numeric or boolean must be quoted with either braces or with double quotes), then an operand is left as a string (and only a limited set of operators may be applied to it). .PP .VS 8.4 On 32-bit systems, integer values MAX_INT (0x7FFFFFFF) and MIN_INT (-0x80000000) will be represented as 32-bit values, and integer values outside that range will be represented as 64-bit values (if that is possible at all.) .VE 8.4 .PP Operands may be specified in any of the following ways: .IP [1] As a numeric value, either integer or floating-point. .IP [2] As a boolean value, using any form understood by \fBstring is boolean\fR. .IP [3] As a Tcl variable, using standard \fB$\fR notation. The variable's value will be used as the operand. .IP [4] As a string enclosed in double-quotes. The expression parser will perform backslash, variable, and command substitutions on the information between the quotes, and use the resulting value as the operand .IP [5] As a string enclosed in braces. The characters between the open brace and matching close brace will be used as the operand without any substitutions. .IP [6] As a Tcl command enclosed in brackets. The command will be executed and its result will be used as the operand. .IP [7] As a mathematical function whose arguments have any of the above forms for operands, such as \fBsin($x)\fR. See below for a list of defined functions. .LP Where the above substitutions occur (e.g. inside quoted strings), they are performed by the expression's instructions. However, the command parser may already have performed one round of substitution before the expression processor was called. As discussed below, it is usually best to enclose expressions in braces to prevent the command parser from performing substitutions on the contents. .PP For some examples of simple expressions, suppose the variable \fBa\fR has the value 3 and the variable \fBb\fR has the value 6. |
| ︙ | ︙ | |||
109 110 111 112 113 114 115 | .CE .SH OPERATORS .PP The valid operators are listed below, grouped in decreasing order of precedence: .TP 20 \fB\-\0\0+\0\0~\0\0!\fR | | | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | .CE .SH OPERATORS .PP The valid operators are listed below, grouped in decreasing order of precedence: .TP 20 \fB\-\0\0+\0\0~\0\0!\fR Unary minus, unary plus, bit-wise NOT, logical NOT. None of these operators may be applied to string operands, and bit-wise NOT may be applied only to integers. .TP 20 \fB*\0\0/\0\0%\fR Multiply, divide, remainder. None of these operators may be applied to string operands, and remainder may be applied only to integers. The remainder will always have the same sign as the divisor and an absolute value smaller than the divisor. .TP 20 \fB+\0\0\-\fR Add and subtract. Valid for any numeric operands. |
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | Logical OR. Produces a 0 result if both operands are zero, 1 otherwise. Valid for boolean and numeric (integers or floating-point) operands only. .TP 20 \fIx\fB?\fIy\fB:\fIz\fR If-then-else, as in C. If \fIx\fR evaluates to non-zero, then the result is the value of \fIy\fR. Otherwise the result is the value of \fIz\fR. | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | Logical OR. Produces a 0 result if both operands are zero, 1 otherwise. Valid for boolean and numeric (integers or floating-point) operands only. .TP 20 \fIx\fB?\fIy\fB:\fIz\fR If-then-else, as in C. If \fIx\fR evaluates to non-zero, then the result is the value of \fIy\fR. Otherwise the result is the value of \fIz\fR. The \fIx\fR operand must have a boolean or numeric value. .LP See the C manual for more details on the results produced by each operator. All of the binary operators group left-to-right within the same precedence level. For example, the command .CS \fBexpr 4*2 < 7\fR |
| ︙ | ︙ | |||
190 191 192 193 194 195 196 | only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated, depending on the value of \fB$v\fR. Note, however, that this is only true if the entire expression is enclosed in braces; otherwise the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before invoking the \fBexpr\fR command. .SH "MATH FUNCTIONS" .PP | | > | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | only one of \fB[a]\fR or \fB[b]\fR will actually be evaluated, depending on the value of \fB$v\fR. Note, however, that this is only true if the entire expression is enclosed in braces; otherwise the Tcl parser will evaluate both \fB[a]\fR and \fB[b]\fR before invoking the \fBexpr\fR command. .SH "MATH FUNCTIONS" .PP Tcl supports the following mathematical functions in expressions, all of which work solely with floating-point numbers unless otherwise noted: .DS .ta 3c 6c 9c \fBabs\fR \fBcosh\fR \fBlog\fR \fBsqrt\fR \fBacos\fR \fBdouble\fR \fBlog10\fR \fBsrand\fR \fBasin\fR \fBexp\fR \fBpow\fR \fBtan\fR \fBatan\fR \fBfloor\fR \fBrand\fR \fBtanh\fR \fBatan2\fR \fBfmod\fR \fBround\fR \fBwide\fR \fBceil\fR \fBhypot\fR \fBsin\fR \fBcos\fR \fBint\fR \fBsinh\fR .DE .PP .TP \fBabs(\fIarg\fB)\fR Returns the absolute value of \fIarg\fR. \fIArg\fR may be either |
| ︙ | ︙ | |||
225 226 227 228 229 230 231 | .TP \fBatan2(\fIy, x\fB)\fR Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI-pi\fR,\fIpi\fR] radians. \fIx\fR and \fIy\fR cannot both be 0. If \fIx\fR is greater than \fI0\fR, this is equivalent to \fBatan(\fIy/x\fB)\fR. .TP \fBceil(\fIarg\fB)\fR | | | | | | > | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 | .TP \fBatan2(\fIy, x\fB)\fR Returns the arc tangent of \fIy\fR/\fIx\fR, in the range [\fI-pi\fR,\fIpi\fR] radians. \fIx\fR and \fIy\fR cannot both be 0. If \fIx\fR is greater than \fI0\fR, this is equivalent to \fBatan(\fIy/x\fB)\fR. .TP \fBceil(\fIarg\fB)\fR Returns the smallest integral floating-point value (i.e. with a zero fractional part) not less than \fIarg\fR. .TP \fBcos(\fIarg\fB)\fR Returns the cosine of \fIarg\fR, measured in radians. .TP \fBcosh(\fIarg\fB)\fR Returns the hyperbolic cosine of \fIarg\fR. If the result would cause an overflow, an error is returned. .TP \fBdouble(\fIarg\fB)\fR If \fIarg\fR is a floating-point value, returns \fIarg\fR, otherwise converts \fIarg\fR to floating-point and returns the converted value. .TP \fBexp(\fIarg\fB)\fR Returns the exponential of \fIarg\fR, defined as \fIe\fR**\fIarg\fR. If the result would cause an overflow, an error is returned. .TP \fBfloor(\fIarg\fB)\fR Returns the largest integral floating-point value (i.e. with a zero fractional part) not greater than \fIarg\fR. .TP \fBfmod(\fIx, y\fB)\fR Returns the floating-point remainder of the division of \fIx\fR by \fIy\fR. If \fIy\fR is 0, an error is returned. .TP \fBhypot(\fIx, y\fB)\fR Computes the length of the hypotenuse of a right-angled triangle \fBsqrt(\fIx\fR*\fIx\fR+\fIy\fR*\fIy\fB)\fR. .TP \fBint(\fIarg\fB)\fR .VS 8.4 If \fIarg\fR is an integer value of the same width as the machine word, returns \fIarg\fR, otherwise converts \fIarg\fR to an integer (of the same size as a machine word, i.e. 32-bits on 32-bit systems, and 64-bits on 64-bit systems) by truncation and returns the converted value. .VE 8.4 .TP \fBlog(\fIarg\fB)\fR Returns the natural logarithm of \fIarg\fR. \fIArg\fR must be a positive value. .TP \fBlog10(\fIarg\fB)\fR Returns the base 10 logarithm of \fIarg\fR. \fIArg\fR must be a positive value. .TP \fBpow(\fIx, y\fB)\fR Computes the value of \fIx\fR raised to the power \fIy\fR. If \fIx\fR is negative, \fIy\fR must be an integer value. .TP \fBrand()\fR Returns a pseudo-random floating-point value in the range (\fI0\fR,\fI1\fR). The generator algorithm is a simple linear congruential generator that is not cryptographically secure. Each result from \fBrand\fR completely determines all future results from subsequent calls to \fBrand\fR, so \fBrand\fR should not be used to generate a sequence of secrets, such as one-time passwords. The seed of the generator is initialized from the internal clock of the machine or may be set with the \fBsrand\fR function. .TP |
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | .TP \fBsqrt(\fIarg\fB)\fR Returns the square root of \fIarg\fR. \fIArg\fR must be non-negative. .TP \fBsrand(\fIarg\fB)\fR The \fIarg\fR, which must be an integer, is used to reset the seed for the random number generator of \fBrand\fR. Returns the first random | | | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 | .TP \fBsqrt(\fIarg\fB)\fR Returns the square root of \fIarg\fR. \fIArg\fR must be non-negative. .TP \fBsrand(\fIarg\fB)\fR The \fIarg\fR, which must be an integer, is used to reset the seed for the random number generator of \fBrand\fR. Returns the first random number (see \fBrand()\fR) from that seed. Each interpreter has its own seed. .TP \fBtan(\fIarg\fB)\fR Returns the tangent of \fIarg\fR, measured in radians. .TP \fBtanh(\fIarg\fB)\fR Returns the hyperbolic tangent of \fIarg\fR. .TP \fBwide(\fIarg\fB)\fR .VS 8.4 Converts \fIarg\fR to an integer value at least 64-bits wide (by sign-extension if \fIarg\fR is a 32-bit number) if it is not one already. .VE 8.4 .PP In addition to these predefined functions, applications may define additional functions using \fBTcl_CreateMathFunc\fR(). .SH "TYPES, OVERFLOW, AND PRECISION" .PP All internal computations involving integers are done with the C type |
| ︙ | ︙ | |||
353 354 355 356 357 358 359 | Floating-point values are always returned with a ``\fB.\fR'' or an \fBe\fR so that they will not look like integer values. For example, .CS \fBexpr 20.0/5.0\fR .CE returns \fB4.0\fR, not \fB4\fR. | < | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 | Floating-point values are always returned with a ``\fB.\fR'' or an \fBe\fR so that they will not look like integer values. For example, .CS \fBexpr 20.0/5.0\fR .CE returns \fB4.0\fR, not \fB4\fR. .SH "STRING OPERATIONS" .PP String values may be used as operands of the comparison operators, although the expression evaluator tries to do comparisons as integer or floating-point when it can, .VS 8.4 except in the case of the \fBeq\fR and \fBne\fR operators. |
| ︙ | ︙ | |||
414 415 416 417 418 419 420 | need two rounds of substitutions, the bytecode compiler must emit additional instructions to handle this situation. The most expensive code is required for unbraced expressions that contain command substitutions. These expressions must be implemented by generating new code each time the expression is executed. | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 |
need two rounds of substitutions,
the bytecode compiler must emit
additional instructions to handle this situation.
The most expensive code is required for
unbraced expressions that contain command substitutions.
These expressions must be implemented by generating new code
each time the expression is executed.
.SH EXAMPLES
Define a procedure that computes an "interesting" mathematical
function:
.CS
proc calc {x y} {
\fBexpr\fR { ($x*$x - $y*$y) / exp($x*$x + $y*$y) }
}
.CE
.PP
Convert polar coordinates into cartesian coordinates:
.CS
# convert from ($radius,$angle)
set x [\fBexpr\fR { $radius * cos($angle) }]
set y [\fBexpr\fR { $radius * sin($angle) }]
.CE
.PP
Convert cartesian coordinates into polar coordinates:
.CS
# convert from ($x,$y)
set radius [\fBexpr\fR { hypot($y, $x) }]
set angle [\fBexpr\fR { atan2($y, $x) }]
.CE
.PP
Print a message describing the relationship of two string values to
each other:
.CS
puts "a and b are [\fBexpr\fR {$a eq $b ? {equal} : {different}}]"
.CE
.PP
Set a variable to whether an environment variable is both defined at
all and also set to a true boolean value:
.CS
set isTrue [\fBexpr\fR {
[info exists ::env(SOME_ENV_VAR)] &&
[string is true -strict $::env(SOME_ENV_VAR)]
}]
.CE
.PP
Generate a random integer in the range 0..99 inclusive:
.CS
set randNum [\fBexpr\fR { int(100 * rand()) }]
.CE
.SH "SEE ALSO"
array(n), for(n), if(n), string(n), Tcl(n), while(n)
.SH KEYWORDS
arithmetic, boolean, compare, expression, fuzzy comparison
|
Changes to doc/fblocked.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: fblocked.n,v 1.4.8.1 2004/10/27 12:52:39 dkf Exp $ .so man.macros .TH fblocked n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fblocked \- Test whether the last input operation exhausted all available input .SH SYNOPSIS |
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | .PP .VS \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .VE | > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.SH EXAMPLE
The \fBfblocked\fR command is particularly useful when writing network
servers, as it allows you to write your code in a line-by-line style
without preventing the servicing of other connections. This can be
seen in this simple echo-service:
.PP
.CS
# This is called whenever a new client connects to the server
proc connect {chan host port} {
set clientName [format <%s:%d> $host $port]
puts "connection from $clientName"
fconfigure $chan -blocking 0 -buffering line
fileevent $chan readable [list echoLine $chan $clientName]
}
# This is called whenever either at least one byte of input
# data is available, or the channel was closed by the client.
proc echoLine {chan clientName} {
gets $chan line
if {[eof $chan]} {
puts "finishing connection from $clientName"
close $chan
} elseif {![\fBfblocked\fR $chan]} {
# Didn't block waiting for end-of-line
puts "$clientName - $line"
puts $chan $line
}
}
# Create the server socket and enter the event-loop to wait
# for incoming connections...
socket -server connect 12345
vwait forever
.CE
.SH "SEE ALSO"
gets(n), open(n), read(n), socket(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, nonblocking
|
Changes to doc/fconfigure.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: fconfigure.n,v 1.7.2.3 2006/03/14 22:51:13 andreas_kupries Exp $ '\" .so man.macros .TH fconfigure n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fconfigure \- Set and get options on a channel |
| ︙ | ︙ | |||
161 162 163 164 165 166 167 168 169 170 171 172 173 174 | \fBbinary\fR . No end-of-line translations are performed. This is nearly identical to \fBlf\fP mode, except that in addition \fBbinary\fP mode also sets the end-of-file character to the empty string (which disables it) and sets the encoding to \fBbinary\fR (which disables encoding filtering). See the description of \fB\-eofchar\fR and \fB\-encoding\fR for more information. .TP \fBcr\fR . The end of a line in the underlying file or device is represented by a single carriage return character. As the input translation mode, \fBcr\fP mode converts carriage returns to newline characters. As the output translation mode, \fBcr\fP mode translates newline characters to | > > > > > > > | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | \fBbinary\fR . No end-of-line translations are performed. This is nearly identical to \fBlf\fP mode, except that in addition \fBbinary\fP mode also sets the end-of-file character to the empty string (which disables it) and sets the encoding to \fBbinary\fR (which disables encoding filtering). See the description of \fB\-eofchar\fR and \fB\-encoding\fR for more information. .PP .RS Internally, i.e. when it comes to the actual behaviour of the translator this value \fBis\fR identical to \fBlf\fR and is therefore reported as such when queried. Even if \fBbinary\fR was used to set the translation. .RE .TP \fBcr\fR . The end of a line in the underlying file or device is represented by a single carriage return character. As the input translation mode, \fBcr\fP mode converts carriage returns to newline characters. As the output translation mode, \fBcr\fP mode translates newline characters to |
| ︙ | ︙ | |||
188 189 190 191 192 193 194 | . The end of a line in the underlying file or device is represented by a single newline (linefeed) character. In this mode no translations occur during either input or output. This mode is typically used on UNIX platforms. .RE .PP | < | | < < < < < | < < | < < < < < < < < | | < | < < < | < < < < < < < < < | < < | < < < | < < < | > < < < < | < | < < < < < < < < < | < > | < | < < < < < > > > | < < < > | < < < < < < < | | < | < < < < < < | | | | | | | | | < < | < < | > > > > | | | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | < < < < < < < < < < < < < | < < < > | < < < < < < < < < < > | | < < < < < | < < < < < < | < | | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
.
The end of a line in the underlying file or device is represented by a
single newline (linefeed) character. In this mode no translations occur
during either input or output. This mode is typically used on UNIX
platforms.
.RE
.PP
.SH "STANDARD CHANNELS"
.PP
The Tcl standard channels (\fBstdin\fR, \fBstdout\fR, and \fBstderr\fR)
can be configured through this command like every other channel opened
by the Tcl library. Beyond the standard options described above they
will also support any special option according to their current type.
If, for example, a Tcl application is started by the \fBinet\fR
super-server common on Unix system its Tcl standard channels will be
sockets and thus support the socket options.
.SH EXAMPLES
Instruct Tcl to always send output to \fBstdout\fR immediately,
whether or not it is to a terminal:
.CS
\fBfconfigure\fR stdout -buffering none
.CE
.PP
Open a socket and read lines from it without ever blocking the
processing of other events:
.CS
set s [socket some.where.com 12345]
\fBfconfigure\fR $s -blocking 0
fileevent $s readable "readMe $s"
proc readMe chan {
if {[gets $chan line] < 0} {
if {[eof $chan]} {
close $chan
return
}
# Could not read a complete line this time; Tcl's
# internal buffering will hold the partial line for us
# until some more data is available over the socket.
} else {
puts stdout $line
}
}
.CE
.PP
Read a PPM-format image from a file:
.CS
# Open the file and put it into Unix ASCII mode
set f [open teapot.ppm]
\fBfconfigure\fR $f \-encoding ascii \-translation lf
# Get the header
if {[gets $f] ne "P6"} {
error "not a raw\-bits PPM"
}
# Read lines until we have got non-comment lines
# that supply us with three decimal values.
set words {}
while {[llength $words] < 3} {
gets $f line
if {[string match "#*" $line]} continue
lappend words [eval concat [scan $line %d%d%d]]
}
# Those words supply the size of the image and its
# overall depth per channel. Assign to variables.
foreach {xSize ySize depth} $words {break}
# Now switch to binary mode to pull in the data,
# one byte per channel (red,green,blue) per pixel.
\fBfconfigure\fR $f \-translation binary
set numDataBytes [expr {3 * $xSize * $ySize}]
set data [read $f $numDataBytes]
close $f
.CE
.SH "SEE ALSO"
close(n), flush(n), gets(n), open(n), puts(n), read(n), socket(n),
Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, buffering, carriage return, end of line, flushing, linemode,
newline, nonblocking, platform, translation, encoding, filter, byte array,
binary
|
Changes to doc/fcopy.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: fcopy.n,v 1.3.14.1 2007/01/29 16:50:35 dgp Exp $ '\" .so man.macros .TH fcopy n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fcopy \- Copy data from one channel to another. |
| ︙ | ︙ | |||
111 112 113 114 115 116 117 |
.PP
The second example copies in chunks and tests for end of file
in the command callback
.DS
proc CopyMore {in out chunk bytes {error {}}} {
global total done
incr total $bytes
| | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
.PP
The second example copies in chunks and tests for end of file
in the command callback
.DS
proc CopyMore {in out chunk bytes {error {}}} {
global total done
incr total $bytes
if {([string length $error] != 0) || [eof $in]} {
set done $total
close $in
close $out
} else {
fcopy $in $out -command [list CopyMore $in $out $chunk] \\
-size $chunk
}
|
| ︙ | ︙ |
Changes to doc/file.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: file.n,v 1.23.2.3 2006/12/04 09:12:02 dkf Exp $ '\" .so man.macros .TH file n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME file \- Manipulate file names and attributes |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 | \fItargetDir\fR of each \fIsource\fR file listed. If a directory is specified as a \fIsource\fR, then the contents of the directory will be recursively copied into \fItargetDir\fR. Existing files will not be overwritten unless the \fB\-force\fR option is specified. When copying within a single filesystem, \fIfile copy\fR will copy soft links (i.e. the links themselves are copied, not the things they point to). Trying to overwrite a non-empty directory, overwrite a directory with a file, | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | \fItargetDir\fR of each \fIsource\fR file listed. If a directory is specified as a \fIsource\fR, then the contents of the directory will be recursively copied into \fItargetDir\fR. Existing files will not be overwritten unless the \fB\-force\fR option is specified. When copying within a single filesystem, \fIfile copy\fR will copy soft links (i.e. the links themselves are copied, not the things they point to). Trying to overwrite a non-empty directory, overwrite a directory with a file, or overwrite a file with a directory will all result in errors even if \fI\-force\fR was specified. Arguments are processed in the order specified, halting at the first error, if any. A \fB\-\|\-\fR marks the end of switches; the argument following the \fB\-\|\-\fR will be treated as a \fIsource\fR even if it starts with a \fB\-\fR. .RE .TP \fBfile delete \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIpathname\fR ?\fIpathname\fR ... ? |
| ︙ | ︙ | |||
196 197 198 199 200 201 202 | If only one argument is given, that argument is assumed to be \fIlinkName\fR, and this command returns the value of the link given by \fIlinkName\fR (i.e. the name of the file it points to). If \fIlinkName\fR isn't a link or its value cannot be read (as, for example, seems to be the case with hard links, which look just like ordinary files), then an error is returned. . | | | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 | If only one argument is given, that argument is assumed to be \fIlinkName\fR, and this command returns the value of the link given by \fIlinkName\fR (i.e. the name of the file it points to). If \fIlinkName\fR isn't a link or its value cannot be read (as, for example, seems to be the case with hard links, which look just like ordinary files), then an error is returned. . If 2 arguments are given, then these are assumed to be \fIlinkName\fR and \fItarget\fR. If \fIlinkName\fR already exists, or if \fItarget\fR doesn't exist, an error will be returned. Otherwise, Tcl creates a new link called \fIlinkName\fR which points to the existing filesystem object at \fItarget\fR, where the type of the link is platform-specific (on Unix a symbolic link will be the default). This is useful for the case where the user wishes to create a link in a cross-platform way, and doesn't care what type of link is created. . |
| ︙ | ︙ | |||
254 255 256 257 258 259 260 | Returns the platform-specific name of the file. This is useful if the filename is needed to pass to a platform-specific call, such as exec under Windows or AppleScript on the Macintosh. .TP \fBfile normalize \fIname\fR . .RS | | | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 | Returns the platform-specific name of the file. This is useful if the filename is needed to pass to a platform-specific call, such as exec under Windows or AppleScript on the Macintosh. .TP \fBfile normalize \fIname\fR . .RS Returns a unique normalized path representation for the file-system object (file, directory, link, etc), whose string value can be used as a unique identifier for it. A normalized path is an absolute path which has all '../', './' removed. Also it is one which is in the ``standard'' format for the native platform. On MacOS, Unix, this means the segments leading up to the path must be free of symbolic links/aliases (but the very last path component may be a symbolic link), and on Windows it also means we want the long form with that form's case-dependence (which gives us a unique, case-dependent path). The one exception concerning the last link in the path is necessary, because Tcl or the user may wish to operate on the actual symbolic link itself (for example 'file delete', 'file rename', 'file copy' are defined to operate on symbolic links, not on the things that they point to). .RE .TP \fBfile owned \fIname\fR . Returns \fB1\fR if file \fIname\fR is owned by the current user, \fB0\fR otherwise. .TP \fBfile pathtype \fIname\fR . Returns one of \fBabsolute\fR, \fBrelative\fR, \fBvolumerelative\fR. If \fIname\fR refers to a specific file on a specific volume, the path type will be \fBabsolute\fR. If \fIname\fR refers to a file relative to the current working directory, then the path type will be \fBrelative\fR. If \fIname\fR refers to a file relative to the current working directory on a specified volume, or to a specific file on the current working volume, then the path type is \fBvolumerelative\fR. .TP \fBfile readable \fIname\fR . Returns \fB1\fR if file \fIname\fR is readable by the current user, \fB0\fR otherwise. .TP \fBfile readlink \fIname\fR |
| ︙ | ︙ | |||
414 415 416 417 418 419 420 421 422 423 424 425 426 427 | \fB0\fR otherwise. .SH "PORTABILITY ISSUES" .TP \fBUnix\fR\0\0\0\0\0\0\0 . These commands always operate using the real user and group identifiers, not the effective ones. .SH "SEE ALSO" filename(n), open(n), close(n), eof(n), gets(n), tell(n), seek(n), fblocked(n), flush(n) .SH KEYWORDS attributes, copy files, delete files, directory, file, move files, name, rename files, stat | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
\fB0\fR otherwise.
.SH "PORTABILITY ISSUES"
.TP
\fBUnix\fR\0\0\0\0\0\0\0
.
These commands always operate using the real user and group identifiers,
not the effective ones.
.SH EXAMPLES
This procedure shows how to search for C files in a given directory
that have a correspondingly-named object file in the current
directory:
.CS
proc findMatchingCFiles {dir} {
set files {}
switch $::tcl_platform(platform) {
windows {
set ext .obj
}
unix {
set ext .o
}
}
foreach file [glob -nocomplain -directory $dir *.c] {
set objectFile [\fBfile tail\fR [\fBfile rootname\fR $file]]$ext
if {[\fBfile exists\fR $objectFile]} {
lappend files $file
}
}
return $files
}
.CE
.PP
Rename a file and leave a symbolic link pointing from the old location
to the new place:
.CS
set oldName foobar.txt
set newName foo/bar.txt
# Make sure that where we're going to move to exists...
if {![\fBfile isdirectory\fR [\fBfile dirname\fR $newName]]} {
\fBfile mkdir\fR [\fBfile dirname\fR $newName]
}
\fBfile rename\fR $oldName $newName
\fBfile link\fR -symbolic $oldName $newName
.CE
.SH "SEE ALSO"
filename(n), open(n), close(n), eof(n), gets(n), tell(n), seek(n),
fblocked(n), flush(n)
.SH KEYWORDS
attributes, copy files, delete files, directory, file, move files, name, rename files, stat
|
Changes to doc/fileevent.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: fileevent.n,v 1.5.6.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH fileevent n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME fileevent \- Execute a script when a channel becomes readable or writable |
| ︙ | ︙ | |||
96 97 98 99 100 101 102 | context of any Tcl procedure) in the interpreter in which the \fBfileevent\fR command was invoked. If an error occurs while executing the script then the \fBbgerror\fR mechanism is used to report the error. In addition, the file event handler is deleted if it ever returns an error; this is done in order to prevent infinite loops due to buggy handlers. | < < > > | | | < < < | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
context of any Tcl procedure) in the interpreter in which the
\fBfileevent\fR command was invoked.
If an error occurs while executing the script then the
\fBbgerror\fR mechanism is used to report the error.
In addition, the file event handler is deleted if it ever returns
an error; this is done in order to prevent infinite loops due to
buggy handlers.
.SH EXAMPLE
In this setup \fBGetData\fR will be called with the channel as an
argument whenever $chan becomes readable.
.CS
proc GetData {chan} {
if {![eof $chan]} {
puts [gets $chan]
}
}
\fBfileevent\fR $chan readable [list GetData $chan]
.CE
.SH CREDITS
.PP
\fBfileevent\fR is based on the \fBaddinput\fR command created
by Mark Diekhans.
.SH "SEE ALSO"
bgerror(n), fconfigure(n), gets(n), puts(n), read(n), Tcl_StandardChannels(3)
.SH KEYWORDS
asynchronous I/O, blocking, channel, event handler, nonblocking, readable,
script, writable.
|
Changes to doc/filename.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: filename.n,v 1.7.12.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH filename n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME filename \- File name conventions supported by Tcl commands |
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | alphanumeric characters only. Also Windows 3.1 only supports file names with a root of no more than 8 characters and an extension of no more than 3 characters. .PP On Windows platforms there are file and path length restrictions. Complete paths or filenames longer than about 260 characters will lead to errors in most file operations. | | > > > > > > > | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 | alphanumeric characters only. Also Windows 3.1 only supports file names with a root of no more than 8 characters and an extension of no more than 3 characters. .PP On Windows platforms there are file and path length restrictions. Complete paths or filenames longer than about 260 characters will lead to errors in most file operations. .PP Another Windows peculiarity is that any number of trailing dots '.' in filenames are totally ignored, so, for example, attempts to create a file or directory with a name "foo." will result in the creation of a file/directory with name "foo". This fact is reflected in the results of 'file normalize'. Furthermore, a file name consisting only of dots '.........' or dots with trailing characters '.....abc' is illegal. .SH KEYWORDS current directory, absolute file name, relative file name, volume-relative file name, portability .SH "SEE ALSO" file(n), glob(n) |
Changes to doc/flush.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: flush.n,v 1.4.8.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH flush n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME flush \- Flush buffered output for a channel |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 37 38 39 40 41 42 | .VE .PP If the channel is in blocking mode the command does not return until all the buffered output has been flushed to the channel. If the channel is in nonblocking mode, the command may return before all buffered output has been flushed; the remainder will be flushed in the background as fast as the underlying file or device is able to absorb it. .SH "SEE ALSO" file(n), open(n), socket(n), Tcl_StandardChannels(3) .SH KEYWORDS blocking, buffer, channel, flush, nonblocking, output | > > > > > > > > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | .VE .PP If the channel is in blocking mode the command does not return until all the buffered output has been flushed to the channel. If the channel is in nonblocking mode, the command may return before all buffered output has been flushed; the remainder will be flushed in the background as fast as the underlying file or device is able to absorb it. .SH EXAMPLE Prompt for the user to type some information in on the console: .CS puts -nonewline "Please type your name: " \fBflush\fR stdout gets stdin name puts "Hello there, $name!" .CE .SH "SEE ALSO" file(n), open(n), socket(n), Tcl_StandardChannels(3) .SH KEYWORDS blocking, buffer, channel, flush, nonblocking, output |
Changes to doc/for.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: for.n,v 1.3.18.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH for n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME for \- ``For'' loop |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | variable substitutions will be made before the \fBfor\fR command starts executing, which means that variable changes made by the loop body will not be considered in the expression. This is likely to result in an infinite loop. If \fItest\fR is enclosed in braces, variable substitutions are delayed until the expression is evaluated (before each loop iteration), so changes in the variables will be visible. | | | > | > > > > > > > > > > > > > > > > > > > > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
variable substitutions will be made before the \fBfor\fR
command starts executing, which means that variable changes
made by the loop body will not be considered in the expression.
This is likely to result in an infinite loop. If \fItest\fR is
enclosed in braces, variable substitutions are delayed until the
expression is evaluated (before
each loop iteration), so changes in the variables will be visible.
See below for an example:
.SH EXAMPLES
Print a line for each of the integers from 0 to 10:
.CS
for {set x 0} {$x<10} {incr x} {
puts "x is $x"
}
.CE
.PP
Either loop infinitely or not at all because the expression being
evaluated is actually the constant, or even generate an error! The
actual behaviour will depend on whether the variable \fIx\fR exists
before the \fBfor\fR command is run and whether its value is a value
that is less than or greater than/equal to ten, and this is because
the expression will be substituted before the \fBfor\fR command is
executed.
.CS
for {set x 0} $x<10 {incr x} {
puts "x is $x"
}
.CE
.PP
Print out the powers of two from 1 to 1024:
.CS
for {set x 1} {$x<=1024} {set x [expr {$x * 2}]} {
puts "x is $x"
}
.CE
.SH "SEE ALSO"
break, continue, foreach, while
.SH KEYWORDS
for, iteration, looping
|
Changes to doc/foreach.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: foreach.n,v 1.3.18.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH foreach n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME foreach \- Iterate over all elements in one or more lists |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 |
command. \fBForeach\fR returns an empty string.
.SH EXAMPLES
.PP
The following loop uses i and j as loop variables to iterate over
pairs of elements of a single list.
.DS
set x {}
| | | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
command. \fBForeach\fR returns an empty string.
.SH EXAMPLES
.PP
The following loop uses i and j as loop variables to iterate over
pairs of elements of a single list.
.DS
set x {}
\fBforeach\fR {i j} {a b c d e f} {
lappend x $j $i
}
# The value of x is "b a d c f e"
# There are 3 iterations of the loop.
.DE
.PP
The next loop uses i and j to iterate over two lists in parallel.
.DS
set x {}
\fBforeach\fR i {a b c} j {d e f g} {
lappend x $i $j
}
# The value of x is "a d b e c f {} g"
# There are 4 iterations of the loop.
.DE
.PP
The two forms are combined in the following example.
.DS
set x {}
\fBforeach\fR i {a b c} {j k} {d e f g} {
lappend x $i $j $k
}
# The value of x is "a d e b f g c {} {}"
# There are 3 iterations of the loop.
.DE
.SH "SEE ALSO"
for(n), while(n), break(n), continue(n)
.SH KEYWORDS
foreach, iteration, list, looping
|
Changes to doc/format.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: format.n,v 1.7.2.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH format n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME format \- Format a string in the style of sprintf .SH SYNOPSIS \fBformat \fIformatString \fR?\fIarg arg ...\fR? .BE .SH INTRODUCTION .PP This command generates a formatted string in the same way as the ANSI C \fBsprintf\fR procedure (it uses \fBsprintf\fR in its implementation). \fIFormatString\fR indicates how to format the result, using \fB%\fR conversion specifiers as in \fBsprintf\fR, and the additional arguments, if any, provide values to be substituted into the result. The return value from \fBformat\fR is the formatted string. .SH "DETAILS ON FORMATTING" .PP The command operates by scanning \fIformatString\fR from left to right. Each character from the format string is appended to the result string unless it is a percent sign. If the character is a \fB%\fR then it is not copied to the result string. Instead, the characters following the \fB%\fR character are treated as |
| ︙ | ︙ | |||
129 130 131 132 133 134 135 | The fifth part of a conversion specifier is a length modifier, which must be \fBh\fR or \fBl\fR. If it is \fBh\fR it specifies that the numeric value should be truncated to a 16-bit value before converting. This option is rarely useful. .VS 8.4 If it is \fBl\fR it specifies that the numeric value should be (at | | | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 | The fifth part of a conversion specifier is a length modifier, which must be \fBh\fR or \fBl\fR. If it is \fBh\fR it specifies that the numeric value should be truncated to a 16-bit value before converting. This option is rarely useful. .VS 8.4 If it is \fBl\fR it specifies that the numeric value should be (at least) a 64-bit value. If neither \fBh\fR nor \fBl\fR are present, numeric values are interpreted as being values of the width of the native machine word, as described by \fBtcl_platform(wordSize)\fR. .VE .PP The last thing in a conversion specifier is an alphabetic character that determines what kind of conversion to perform. The following conversion characters are currently supported: |
| ︙ | ︙ | |||
192 193 194 195 196 197 198 | \fB%\fR No conversion: just insert \fB%\fR. .LP For the numerical conversions the argument being converted must be an integer or floating-point string; format converts the argument to binary and then converts it back to a string according to the conversion specifier. | < | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 | \fB%\fR No conversion: just insert \fB%\fR. .LP For the numerical conversions the argument being converted must be an integer or floating-point string; format converts the argument to binary and then converts it back to a string according to the conversion specifier. .SH "DIFFERENCES FROM ANSI SPRINTF" .PP The behavior of the format command is the same as the ANSI C \fBsprintf\fR procedure except for the following differences: .IP [1] \fB%p\fR and \fB%n\fR specifiers are not currently supported. |
| ︙ | ︙ | |||
214 215 216 217 218 219 220 221 222 | converted as if the \fBl\fR modifier were present (i.e. the types \fBdouble\fR and \fBlong\fR are used for the internal representation of real and integer values, respectively). .VE 8.4 If the \fBh\fR modifier is specified then integer values are truncated to \fBshort\fR before conversion. Both \fBh\fR and \fBl\fR modifiers are ignored on all other conversions. .SH "SEE ALSO" | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
converted as if the \fBl\fR modifier were present (i.e. the types
\fBdouble\fR and \fBlong\fR are used for the internal representation
of real and integer values, respectively).
.VE 8.4
If the \fBh\fR modifier is specified then integer values are truncated
to \fBshort\fR before conversion. Both \fBh\fR and \fBl\fR modifiers
are ignored on all other conversions.
.SH EXAMPLES
Convert the output of \fBtime\fR into seconds to an accuracy of
hundredths of a second:
.CS
set us [lindex [time $someTclCode] 0]
puts [\fBformat\fR "%.2f seconds to execute" [expr {$us / 1e6}]]
.CE
.PP
Create a packed X11 literal color specification:
.CS
# Each color-component should be in range (0..255)
set color [\fBformat\fR "#%02x%02x%02x" $r $g $b]
.CE
.PP
Use XPG3 format codes to allow reordering of fields (a technique that
is often used in localized message catalogs; see \fBmsgcat\fR) without
reordering the data values passed to \fBformat\fR:
.CS
set fmt1 "Today, %d shares in %s were bought at $%.2f each"
puts [\fBformat\fR $fmt1 123 "Global BigCorp" 19.37]
set fmt2 "Bought %2\\$s equity ($%3$.2f x %1\\$d) today"
puts [\fBformat\fR $fmt2 123 "Global BigCorp" 19.37]
.CE
.PP
Print a small table of powers of three:
.CS
# Set up the column widths
set w1 5
set w2 10
# Make a nice header (with separator) for the table first
set sep +-[string repeat - $w1]-+-[string repeat - $w2]-+
puts $sep
puts [\fBformat\fR "| %-*s | %-*s |" $w1 "Index" $w2 "Power"]
puts $sep
# Print the contents of the table
set p 1
for {set i 0} {$i<=20} {incr i} {
puts [\fBformat\fR "| %*d | %*ld |" $w1 $i $w2 $p]
set p [expr {wide($p) * 3}]
}
# Finish off by printing the separator again
puts $sep
.CE
.SH "SEE ALSO"
scan(n), sprintf(3), string(n)
.SH KEYWORDS
conversion specifier, format, sprintf, string, substitution
|
Changes to doc/gets.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: gets.n,v 1.4.8.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH gets n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME gets \- Read a line from a channel |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 54 55 56 57 58 59 | data in nonblocking mode, then the return count is -1. Note that if \fIvarName\fR is not specified then the end-of-file and no-full-line-available cases can produce the same results as if there were an input line consisting only of the end-of-line character(s). The \fBeof\fR and \fBfblocked\fR commands can be used to distinguish these three cases. .SH "SEE ALSO" file(n), eof(n), fblocked(n), Tcl_StandardChannels(3) .SH KEYWORDS blocking, channel, end of file, end of line, line, nonblocking, read | > > > > > > > > > > > > | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
data in nonblocking mode, then the return count is -1.
Note that if \fIvarName\fR is not specified then the end-of-file
and no-full-line-available cases can
produce the same results as if there were an input line consisting
only of the end-of-line character(s).
The \fBeof\fR and \fBfblocked\fR commands can be used to distinguish
these three cases.
.SH "EXAMPLE"
This example reads a file one line at a time and prints it out with
the current line number attached to the start of each line.
.PP
.CS
set chan [open "some.file.txt"]
set lineNumber 0
while {[\fBgets\fR $chan line] >= 0} {
puts "[incr lineNumber]: $line"
}
close $chan
.CE
.SH "SEE ALSO"
file(n), eof(n), fblocked(n), Tcl_StandardChannels(3)
.SH KEYWORDS
blocking, channel, end of file, end of line, line, nonblocking, read
|
Changes to doc/glob.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: glob.n,v 1.12.2.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH glob n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME glob \- Return names of files that match patterns |
| ︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 83 84 85 86 87 | \fIc\fR (character special file), \fId\fR (directory), \fIf\fR (plain file), \fIl\fR (symbolic link), \fIp\fR (named pipe), or \fIs\fR (socket), where multiple types may be specified in the list. \fBGlob\fR will return all files which match at least one of the types given. .RS .PP The second form specifies types where all the types given must match. These are \fIr\fR, \fIw\fR, \fIx\fR as file permissions, and \fIreadonly\fR, \fIhidden\fR as special permission cases. On the Macintosh, MacOS types and creators are also supported, where any item which is four characters long is assumed to be a MacOS type | > > > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | \fIc\fR (character special file), \fId\fR (directory), \fIf\fR (plain file), \fIl\fR (symbolic link), \fIp\fR (named pipe), or \fIs\fR (socket), where multiple types may be specified in the list. \fBGlob\fR will return all files which match at least one of the types given. Note that symbolic links will be returned both if \fB\-types l\fR is given, or if the target of a link matches the requested type. So, a link to a directory will be returned if \fB\-types d\fR was specified. .RS .PP The second form specifies types where all the types given must match. These are \fIr\fR, \fIw\fR, \fIx\fR as file permissions, and \fIreadonly\fR, \fIhidden\fR as special permission cases. On the Macintosh, MacOS types and creators are also supported, where any item which is four characters long is assumed to be a MacOS type |
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | .LP The \fBglob\fR command differs from csh globbing in two ways. First, it does not sort its result list (use the \fBlsort\fR command if you want the list sorted). Second, \fBglob\fR only returns the names of files that actually exist; in csh no check for existence is made unless a pattern contains a ?, *, or [] construct. | | > > > > > > | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | .LP The \fBglob\fR command differs from csh globbing in two ways. First, it does not sort its result list (use the \fBlsort\fR command if you want the list sorted). Second, \fBglob\fR only returns the names of files that actually exist; in csh no check for existence is made unless a pattern contains a ?, *, or [] construct. .LP When the \fBglob\fR command returns relative paths whose filenames start with a tilde ``~'' (for example through \fBglob *\fR or \fBglob -tails\fR, the returned list will not quote the tilde with ``./''. This means care must be taken if those names are later to be used with \fBfile join\fR, to avoid them being interpreted as absolute paths pointing to a given user's home directory. .SH "PORTABILITY ISSUES" .PP Unlike other Tcl commands that will accept both network and native style names (see the \fBfilename\fR manual entry for details on how native and network names are specified), the \fBglob\fR command only accepts native names. .TP |
| ︙ | ︙ | |||
180 181 182 183 184 185 186 187 188 189 190 191 192 | .TP \fBMacintosh\fR . When using the options, \fB\-directory\fR, \fB\-join\fR or \fB\-path\fR, glob assumes the directory separator for the entire pattern is the standard ``:''. When not using these options, glob examines each pattern argument and uses ``/'' unless the pattern contains a ``:''. .SH "SEE ALSO" file(n) .SH KEYWORDS exist, file, glob, pattern | > > > > > > > > > > > > > > > > > > > > > | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
.TP
\fBMacintosh\fR
.
When using the options, \fB\-directory\fR, \fB\-join\fR or \fB\-path\fR, glob
assumes the directory separator for the entire pattern is the standard
``:''. When not using these options, glob examines each pattern argument
and uses ``/'' unless the pattern contains a ``:''.
.SH EXAMPLES
Find all the Tcl files in the current directory:
.CS
\fBglob\fR *.tcl
.CE
.PP
Find all the Tcl files in the user's home directory, irrespective of
what the current directory is:
.CS
\fBglob\fR \-directory ~ *.tcl
.CE
.PP
Find all subdirectories of the current directory:
.CS
\fBglob\fR \-type d *
.CE
.PP
Find all files whose name contains an "a", a "b" or the sequence "cde":
.CS
\fBglob\fR \-type f *{a,b,cde}*
.CE
.SH "SEE ALSO"
file(n)
.SH KEYWORDS
exist, file, glob, pattern
|
Changes to doc/global.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | | > > | > > | > | | > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: global.n,v 1.4.2.1 2004/10/27 12:52:40 dkf Exp $
'\"
.so man.macros
.TH global n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
global \- Access global variables
.SH SYNOPSIS
\fBglobal \fIvarname \fR?\fIvarname ...\fR?
.BE
.SH DESCRIPTION
.PP
This command has no effect unless executed in the context of a proc body.
If the \fBglobal\fR command is executed in the context of a proc body, it
creates local variables linked to the corresponding global variables (and
therefore these variables are listed by info locals).
.PP
If \fIvarname\fR contains namespace qualifiers, the local variable's name is
the unqualified name of the global variable, as determined by the
\fBnamespace tail\fR command.
.SH EXAMPLES
This procedure sets the namespace variable \fI::a::x\fR
.CS
proc reset {} {
\fBglobal\fR a::x
set x 0
}
.CE
.PP
This procedure accumulates the strings passed to it in a global
buffer, separated by newlines. It is useful for situations when you
want to build a message piece-by-piece (as if with \fBputs\fR) but
send that full message in a single piece (e.g. over a connection
opened with \fBsocket\fR or as part of a counted HTTP response).
.CS
proc accum {string} {
\fBglobal\fR accumulator
append accumulator $string \\n
}
.CE
.SH "SEE ALSO"
namespace(n), upvar(n), variable(n)
.SH KEYWORDS
global, namespace, procedure, variable
|
Changes to doc/history.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: history.n,v 1.2.40.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH history n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME history \- Manipulate the history list |
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | .TP \fBhistory nextid\fR Returns the number of the next event to be recorded in the history list. It is useful for things like printing the event number in command-line prompts. .TP \fBhistory redo \fR?\fIevent\fR? | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | .TP \fBhistory nextid\fR Returns the number of the next event to be recorded in the history list. It is useful for things like printing the event number in command-line prompts. .TP \fBhistory redo \fR?\fIevent\fR? Re-executes the command indicated by \fIevent\fR and returns its result. \fIEvent\fR defaults to \fB\-1\fR. This command results in history revision: see below for details. .SH "HISTORY REVISION" .PP Pre-8.0 Tcl had a complex history revision mechanism. The current mechanism is more limited, and the old history operations \fBsubstitute\fP and \fBwords\fP have been removed. |
| ︙ | ︙ |
Changes to doc/http.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-2000 by Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | > | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | '\" '\" Copyright (c) 1995-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-2000 by Ajuba Solutions. '\" Copyright (c) 2004 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: http.n,v 1.18.2.3 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH "http" n 2.5 http "Tcl Bundled Packages" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.0 protocol. .SH SYNOPSIS \fBpackage require http ?2.5?\fR .sp \fB::http::config \fI?options?\fR .sp \fB::http::geturl \fIurl ?options?\fR .sp \fB::http::formatQuery\fP \fIkey value\fP ?\fIkey value\fP ...? .sp \fB::http::reset\fP \fItoken\fP ?\fIwhy\fP? .sp \fB::http::wait \fItoken\fR .sp \fB::http::status \fItoken\fR .sp \fB::http::size \fItoken\fR .sp |
| ︙ | ︙ | |||
50 51 52 53 54 55 56 | The \fBhttp\fR package provides the client side of the HTTP/1.0 protocol. The package implements the GET, POST, and HEAD operations of HTTP/1.0. It allows configuration of a proxy host to get through firewalls. The package is compatible with the \fBSafesock\fR security policy, so it can be used by untrusted applets to do URL fetching from a restricted set of hosts. This package can be extended to support additional HTTP transport protocols, such as HTTPS, by providing | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | The \fBhttp\fR package provides the client side of the HTTP/1.0 protocol. The package implements the GET, POST, and HEAD operations of HTTP/1.0. It allows configuration of a proxy host to get through firewalls. The package is compatible with the \fBSafesock\fR security policy, so it can be used by untrusted applets to do URL fetching from a restricted set of hosts. This package can be extended to support additional HTTP transport protocols, such as HTTPS, by providing a custom \fBsocket\fR command, via \fB::http::register\fR. .PP The \fB::http::geturl\fR procedure does a HTTP transaction. Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction is performed. The return value of \fB::http::geturl\fR is a token for the transaction. The value is also the name of an array in the ::http namespace that contains state information about the transaction. The elements |
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | that setting is returned. Otherwise, the options should be a set of flags and values that define the configuration: .RS .TP \fB\-accept\fP \fImimetypes\fP The Accept header of the request. The default is */*, which means that all types of documents are accepted. Otherwise you can supply a | | | > > > > > > > > > | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
that setting is returned. Otherwise, the options should be a set of
flags and values that define the configuration:
.RS
.TP
\fB\-accept\fP \fImimetypes\fP
The Accept header of the request. The default is */*, which means that
all types of documents are accepted. Otherwise you can supply a
comma-separated list of mime type patterns that you are
willing to receive. For example, "image/gif, image/jpeg, text/*".
.TP
\fB\-proxyhost\fP \fIhostname\fP
The name of the proxy host, if any. If this value is the
empty string, the URL host is contacted directly.
.TP
\fB\-proxyport\fP \fInumber\fP
The proxy port number.
.TP
\fB\-proxyfilter\fP \fIcommand\fP
The command is a callback that is made during
\fB::http::geturl\fR
to determine if a proxy is required for a given host. One argument, a
host name, is added to \fIcommand\fR when it is invoked. If a proxy
is required, the callback should return a two-element list containing
the proxy server and proxy port. Otherwise the filter should return
an empty list. The default filter returns the values of the
\fB\-proxyhost\fR and \fB\-proxyport\fR settings if they are
non-empty.
.TP
\fB\-urlencoding\fP \fIencoding\fP
The \fIencoding\fR used for creating the x-url-encoded URLs with
\fB::http::formatQuery\fR. The default is \fButf-8\fR, as specified by RFC
2718. Prior to http 2.5 this was unspecified, and that behavior can be
returned by specifying the empty string (\fB{}\fR), although
\fIiso8859-1\fR is recommended to restore similar behavior but without the
\fB::http::formatQuery\fR throwing an error processing non-latin-1
characters.
.TP
\fB\-useragent\fP \fIstring\fP
The value of the User-Agent header in the HTTP request. The default
is \fB"Tcl http client package 2.4."\fR
.RE
.TP
\fB::http::geturl\fP \fIurl\fP ?\fIoptions\fP?
The \fB::http::geturl\fR command is the main procedure in the package.
The \fB\-query\fR option causes a POST operation and
the \fB\-validate\fR option causes a HEAD operation;
otherwise, a GET operation is performed. The \fB::http::geturl\fR command
returns a \fItoken\fR value that can be used to get
information about the transaction. See the STATE ARRAY and ERRORS section for
details. The \fB::http::geturl\fR command blocks until the operation
completes, unless the \fB\-command\fR option specifies a callback
that is invoked when the HTTP transaction completes.
\fB::http::geturl\fR takes several options:
.RS
.TP
\fB\-binary\fP \fIboolean\fP
Specifies whether to force interpreting the URL data as binary. Normally
this is auto-detected (anything not beginning with a \fBtext\fR content
type or whose content encoding is \fBgzip\fR or \fBcompress\fR is
considered binary data).
.TP
\fB\-blocksize\fP \fIsize\fP
The block size used when reading the URL.
At most \fIsize\fR bytes are read at once. After each block, a call to the
\fB\-progress\fR callback is made (if that option is specified).
.TP
\fB\-channel\fP \fIname\fP
Copy the URL contents to channel \fIname\fR instead of saving it in
\fBstate(body)\fR.
.TP
|
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
upvar #0 $token state
}
.CE
.RE
.TP
\fB\-query\fP \fIquery\fP
This flag causes \fB::http::geturl\fR to do a POST request that passes the
| | | | > | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
upvar #0 $token state
}
.CE
.RE
.TP
\fB\-query\fP \fIquery\fP
This flag causes \fB::http::geturl\fR to do a POST request that passes the
\fIquery\fR to the server. The \fIquery\fR must be an x-url-encoding
formatted query. The \fB::http::formatQuery\fR procedure can be used to
do the formatting.
.TP
\fB\-queryblocksize\fP \fIsize\fP
The block size used when posting query data to the URL.
At most
\fIsize\fR
bytes are written at once. After each block, a call to the
\fB\-queryprogress\fR
callback is made (if that option is specified).
.TP
\fB\-querychannel\fP \fIchannelID\fP
This flag causes \fB::http::geturl\fR to do a POST request that passes the
data contained in \fIchannelID\fR to the server. The data contained in
\fIchannelID\fR must be an x-url-encoding
formatted query unless the \fB\-type\fP option below is used.
If a Content-Length header is not specified via the \fB\-headers\fR options,
\fB::http::geturl\fR attempts to determine the size of the post data
in order to create that header. If it is
unable to determine the size, it returns an error.
.TP
\fB\-queryprogress\fP \fIcallback\fP
|
| ︙ | ︙ | |||
314 315 316 317 318 319 320 | such as HTTPS, by registering a prefix, the default port, and the command to execute to create the Tcl \fBchannel\fR. E.g.: .RS .CS package require http package require tls | | | | | | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 | such as HTTPS, by registering a prefix, the default port, and the command to execute to create the Tcl \fBchannel\fR. E.g.: .RS .CS package require http package require tls ::http::register https 443 ::tls::socket set token [::http::geturl https://my.secure.site/] .CE .RE .TP \fB::http::unregister\fP \fIproto\fP This procedure unregisters a protocol handler that was previously registered via \fB::http::register\fR. .SH "ERRORS" The \fB::http::geturl\fP procedure will raise errors in the following cases: invalid command line options, an invalid URL, a URL on a non-existent host, or a URL at a bad port on an existing host. These errors mean that it cannot even start the network transaction. It will also raise an error if it gets an I/O error while |
| ︙ | ︙ | |||
357 358 359 360 361 362 363 | .PP Alternatively, if the main program flow reaches a point where it needs to know the result of the asynchronous HTTP request, it can call \fB::http::wait\fP and then check status and error, just as the callback does. .PP In any case, you must still call | | | | | | | | | | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 | .PP Alternatively, if the main program flow reaches a point where it needs to know the result of the asynchronous HTTP request, it can call \fB::http::wait\fP and then check status and error, just as the callback does. .PP In any case, you must still call \fB::http::cleanup\fP to delete the state array when you're done. .PP There are other possible results of the HTTP transaction determined by examining the status from \fB::http::status\fP. These are described below. .TP ok If the HTTP transaction completes entirely, then status will be \fBok\fP. However, you should still check the \fB::http::code\fP value to get the HTTP status. The \fB::http::ncode\fP procedure provides just the numeric error (e.g., 200, 404 or 500) while the \fB::http::code\fP procedure returns a value like "HTTP 404 File not found". .TP eof If the server closes the socket without replying, then no error is raised, but the status of the transaction will be \fBeof\fP. .TP error The error message will also be stored in the \fBerror\fP status array element, accessible via \fB::http::error\fP. .PP Another error possibility is that \fB::http::geturl\fP is unable to write all the post query data to the server before the server responds and closes the socket. The error message is saved in the \fBposterror\fP status array element and then \fB::http::geturl\fP attempts to complete the transaction. If it can read the server's response it will end up with an \fBok\fP status, otherwise it will have an \fBeof\fP status. .SH "STATE ARRAY" The \fB::http::geturl\fR procedure returns a \fItoken\fR that can be used to get to the state of the HTTP transaction in the form of a Tcl array. Use this construct to create an easy-to-use array variable: .CS upvar #0 $token state .CE Once the data associated with the URL is no longer needed, the state array should be unset to free up storage. The \fB::http::cleanup\fP procedure is provided for that purpose. The following elements of the array are supported: .RS .TP \fBbody\fR The contents of the URL. This will be empty if the \fB\-channel\fR option has been specified. This value is returned by the \fB::http::data\fP command. |
| ︙ | ︙ | |||
482 483 484 485 486 487 488 | \fBtype\fR A copy of the \fBContent-Type\fR meta-data value. .TP \fBurl\fR The requested URL. .RE .SH EXAMPLE | | | | | | | > | | > | | | | | | | | | | | | | | | | | | | > | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
\fBtype\fR
A copy of the \fBContent-Type\fR meta-data value.
.TP
\fBurl\fR
The requested URL.
.RE
.SH EXAMPLE
.CS
# Copy a URL to a file and print meta-data
proc httpcopy { url file {chunk 4096} } {
set out [open $file w]
set token [\fB::http::geturl\fR $url -channel $out \\
-progress httpCopyProgress -blocksize $chunk]
close $out
# This ends the line started by httpCopyProgress
puts stderr ""
upvar #0 $token state
set max 0
foreach {name value} $state(meta) {
if {[string length $name] > $max} {
set max [string length $name]
}
if {[regexp -nocase ^location$ $name]} {
# Handle URL redirects
puts stderr "Location:$value"
return [httpcopy [string trim $value] $file $chunk]
}
}
incr max
foreach {name value} $state(meta) {
puts [format "%-*s %s" $max $name: $value]
}
return $token
}
proc httpCopyProgress {args} {
puts -nonewline stderr .
flush stderr
}
.CE
.SH "SEE ALSO"
safe(n), socket(n), safesock(n)
.SH KEYWORDS
security policy, socket
|
Changes to doc/if.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: if.n,v 1.3.18.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH if n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME if \- Execute scripts conditionally |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 41 42 43 44 45 46 | The \fBthen\fR and \fBelse\fR arguments are optional ``noise words'' to make the command easier to read. There may be any number of \fBelseif\fR clauses, including zero. \fIBodyN\fR may also be omitted as long as \fBelse\fR is omitted too. The return value from the command is the result of the body script that was executed, or an empty string if none of the expressions was non-zero and there was no \fIbodyN\fR. .SH "SEE ALSO" expr(n), for(n), foreach(n) .SH KEYWORDS boolean, conditional, else, false, if, true | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
The \fBthen\fR and \fBelse\fR arguments are optional
``noise words'' to make the command easier to read.
There may be any number of \fBelseif\fR clauses, including zero.
\fIBodyN\fR may also be omitted as long as \fBelse\fR is omitted too.
The return value from the command is the result of the body script
that was executed, or an empty string
if none of the expressions was non-zero and there was no \fIbodyN\fR.
.SH EXAMPLES
A simple conditional:
.CS
\fBif\fR {$vbl == 1} { puts "vbl is one" }
.CE
.PP
With an \fBelse\fR-clause:
.CS
\fBif\fR {$vbl == 1} {
puts "vbl is one"
} \fBelse\fR {
puts "vbl is not one"
}
.CE
.PP
With an \fBelseif\fR-clause too:
.CS
\fBif\fR {$vbl == 1} {
puts "vbl is one"
} \fBelseif\fR {$vbl == 2} {
puts "vbl is two"
} \fBelse\fR {
puts "vbl is not one or two"
}
.CE
.PP
Remember, expressions can be multi-line, but in that case it can be a
good idea to use the optional \fBthen\fR keyword for clarity:
.CS
\fBif\fR {
$vbl == 1 || $vbl == 2 || $vbl == 3
} \fBthen\fR {
puts "vbl is one, two or three"
}
.CE
.SH "SEE ALSO"
expr(n), for(n), foreach(n)
.SH KEYWORDS
boolean, conditional, else, false, if, true
|
Changes to doc/incr.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: incr.n,v 1.3.18.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH incr n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME incr \- Increment the value of a variable .SH SYNOPSIS \fBincr \fIvarName \fR?\fIincrement\fR? .BE .SH DESCRIPTION .PP Increments the value stored in the variable whose name is \fIvarName\fR. The value of the variable must be an integer. If \fIincrement\fR is supplied then its value (which must be an integer) is added to the value of variable \fIvarName\fR; otherwise 1 is added to \fIvarName\fR. The new value is stored as a decimal string in variable \fIvarName\fR and also returned as result. .SH EXAMPLES Add one to the contents of the variable \fIx\fR: .CS \fBincr\fR x .CE .PP Add 42 to the contents of the variable \fIx\fR: .CS \fBincr\fR x 42 .CE .PP Add the contents of the variable \fIy\fR to the contents of the variable \fIx\fR: .CS \fBincr\fR x $y .CE .PP Add nothing at all to the variable \fIx\fR (often useful for checking whether an argument to a procedure is actually numeric and generating an error if it is not): .CS \fBincr\fR x 0 .CE .SH "SEE ALSO" expr(n) .SH KEYWORDS add, increment, variable, value |
Changes to doc/info.n.
1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1998-2000 Ajuba Solutions '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1998-2000 Ajuba Solutions '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: info.n,v 1.8.2.3 2004/10/27 14:23:56 dkf Exp $ '\" .so man.macros .TH info n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME info \- Return information about the state of the Tcl interpreter |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | including both the built-in commands written in C and the command procedures defined using the \fBproc\fR command. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. \fIpattern\fR can be a qualified name like \fBFoo::print*\fR. That is, it may specify a particular namespace | | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | including both the built-in commands written in C and the command procedures defined using the \fBproc\fR command. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. \fIpattern\fR can be a qualified name like \fBFoo::print*\fR. That is, it may specify a particular namespace using a sequence of namespace names separated by double colons (\fB::\fR), and may have pattern matching special characters at the end to specify a set of commands in that namespace. If \fIpattern\fR is a qualified name, the resulting list of command names has each one qualified with the name of the specified namespace. .TP \fBinfo complete \fIcommand\fR Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of having no unclosed quotes, braces, brackets or array element names. If the command doesn't appear to be complete then 0 is returned. This command is typically used in line-oriented input environments to allow users to type in commands that span multiple lines; if the command isn't complete, the script can delay evaluating it until additional lines have been typed to complete the command. .TP \fBinfo default \fIprocname arg varname\fR |
| ︙ | ︙ | |||
159 160 161 162 163 164 165 166 167 168 169 170 171 172 | If \fIpattern\fR isn't specified, returns a list of all the names of Tcl command procedures in the current namespace. If \fIpattern\fR is specified, only those procedure names in the current namespace matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. .TP \fBinfo script\fR ?\fIfilename\fR? If a Tcl script file is currently being evaluated (i.e. there is a call to \fBTcl_EvalFile\fR active or there is an active invocation of the \fBsource\fR command), then this command returns the name of the innermost file being processed. If \fIfilename\fR is specified, then the return value of this command will be modified for the | > > > > > | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | If \fIpattern\fR isn't specified, returns a list of all the names of Tcl command procedures in the current namespace. If \fIpattern\fR is specified, only those procedure names in the current namespace matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. If \fIpattern\fR contains any namespace separators, they are used to select a namespace relative to the current namespace (or relative to the global namespace if \fIpattern\fR starts with \fB::\fR) to match within; the matching pattern is taken to be the part after the last namespace separator. .TP \fBinfo script\fR ?\fIfilename\fR? If a Tcl script file is currently being evaluated (i.e. there is a call to \fBTcl_EvalFile\fR active or there is an active invocation of the \fBsource\fR command), then this command returns the name of the innermost file being processed. If \fIfilename\fR is specified, then the return value of this command will be modified for the |
| ︙ | ︙ | |||
189 190 191 192 193 194 195 | returns a list of all the names of currently-visible variables. This includes locals and currently-visible globals. If \fIpattern\fR is specified, only those names matching \fIpattern\fR are returned. Matching is determined using the same rules as for \fBstring match\fR. \fIpattern\fR can be a qualified name like \fBFoo::option*\fR. That is, it may specify a particular namespace | | > > > > > > > > > > > > > > > > > > > > > | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
returns a list of all the names of currently-visible variables.
This includes locals and currently-visible globals.
If \fIpattern\fR is specified, only those names matching \fIpattern\fR
are returned. Matching is determined using the same rules as for
\fBstring match\fR.
\fIpattern\fR can be a qualified name like \fBFoo::option*\fR.
That is, it may specify a particular namespace
using a sequence of namespace names separated by double colons (\fB::\fR),
and may have pattern matching special characters
at the end to specify a set of variables in that namespace.
If \fIpattern\fR is a qualified name,
the resulting list of variable names
has each matching namespace variable qualified with the name
of its namespace.
Note that a currently-visible variable may not yet "exist" if it has not
been set (e.g. a variable declared but not set by \fBvariable\fR).
.SH EXAMPLE
This command prints out a procedure suitable for saving in a Tcl
script:
.CS
proc printProc {procName} {
set result [list proc $procName]
set formals {}
foreach var [\fBinfo args\fR $procName] {
if {[\fBinfo default\fR $procName $var def]} {
lappend formals [list $var $def]
} else {
# Still need the list-quoting because variable
# names may properly contain spaces.
lappend formals [list $var]
}
}
puts [lappend result $formals [\fBinfo body\fR $procName]]
}
.CE
.SH "SEE ALSO"
global(n), proc(n)
.SH KEYWORDS
command, information, interpreter, level, namespace, procedure, variable
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/interp.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: interp.n,v 1.9.2.2 2004/10/27 14:23:56 dkf Exp $ '\" .so man.macros .TH interp n 7.6 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME interp \- Create and manipulate Tcl interpreters |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | interpreters. A safe interpreter is a slave whose functions have been greatly restricted, so that it is safe to execute untrusted scripts without fear of them damaging other interpreters or the application's environment. For example, all IO channel creation commands and subprocess creation commands are made inaccessible to safe interpreters. .VS | | | | > | < < < | | | | | | | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
interpreters. A safe interpreter is a slave whose functions have
been greatly restricted, so that it is safe to execute untrusted
scripts without fear of them damaging other interpreters or the
application's environment. For example, all IO channel creation
commands and subprocess creation commands are made inaccessible to safe
interpreters.
.VS
See \fBSAFE INTERPRETERS\fR below for more information on
what features are present in a safe interpreter.
The dangerous functionality is not removed from the safe interpreter;
instead, it is \fIhidden\fR, so that only trusted interpreters can obtain
access to it. For a detailed explanation of hidden commands, see
\fBHIDDEN COMMANDS\fR, below.
The alias mechanism can be used for protected communication (analogous to a
kernel call) between a slave interpreter and its master.
See \fBALIAS INVOCATION\fR, below, for more details
on how the alias mechanism works.
.VE
.PP
A qualified interpreter name is a proper Tcl lists containing a subset of its
ancestors in the interpreter hierarchy, terminated by the string naming the
interpreter in its immediate master. Interpreter names are relative to the
interpreter in which they are used. For example, if \fBa\fR is a slave of
the current interpreter and it has a slave \fBa1\fR, which in turn has a
slave \fBa11\fR, the qualified name of \fBa11\fR in \fBa\fR is the list
\fBa1 a11\fR.
.PP
The \fBinterp\fR command, described below, accepts qualified interpreter
names as arguments; the interpreter in which the command is being evaluated
can always be referred to as \fB{}\fR (the empty list or string). Note that
it is impossible to refer to a master (ancestor) interpreter by name in a
slave interpreter except through aliases. Also, there is no global name by
which one can refer to the first interpreter created in an application.
Both restrictions are motivated by safety concerns.
.SH "THE INTERP COMMAND"
.PP
The \fBinterp\fR command is used to create, delete, and manipulate
slave interpreters, and to share or transfer
channels between interpreters. It can have any of several forms, depending
on the \fIoption\fR argument:
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR
Returns a Tcl list whose elements are the \fItargetCmd\fR and
\fIarg\fRs associated with the alias represented by \fIsrcToken\fR
(this is the value returned when the alias was
created; it is possible that the name of the source command in the
slave is different from \fIsrcToken\fR).
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcToken\fR \fB{}\fR
Deletes the alias for \fIsrcToken\fR in the slave interpreter identified by
\fIsrcPath\fR.
\fIsrcToken\fR refers to the value returned when the alias
was created; if the source command has been renamed, the renamed
command will be deleted.
.TP
\fBinterp\fR \fBalias\fR \fIsrcPath\fR \fIsrcCmd\fR \fItargetPath\fR \fItargetCmd \fR?\fIarg arg ...\fR?
This command creates an alias between one slave and another (see the
\fBalias\fR slave command below for creating aliases between a slave
and its master). In this command, either of the slave interpreters
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | and command, and the \fIarg\fR arguments, if any, specify additional arguments to \fItargetCmd\fR which are prepended to any arguments specified in the invocation of \fIsrcCmd\fR. \fITargetCmd\fR may be undefined at the time of this call, or it may already exist; it is not created by this command. The alias arranges for the given target command to be invoked in the target interpreter whenever the given source command is | | | > > > | | > > > | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | and command, and the \fIarg\fR arguments, if any, specify additional arguments to \fItargetCmd\fR which are prepended to any arguments specified in the invocation of \fIsrcCmd\fR. \fITargetCmd\fR may be undefined at the time of this call, or it may already exist; it is not created by this command. The alias arranges for the given target command to be invoked in the target interpreter whenever the given source command is invoked in the source interpreter. See \fBALIAS INVOCATION\fR below for more details. The command returns a token that uniquely identifies the command created \fIsrcCmd\fR, even if the command is renamed afterwards. The token may but does not have to be equal to \fIsrcCmd\fR. .TP \fBinterp\fR \fBaliases \fR?\fIpath\fR? This command returns a Tcl list of the tokens of all the source commands for aliases defined in the interpreter identified by \fIpath\fR. The tokens correspond to the values returned when the aliases were created (which may not be the same as the current names of the commands). .TP \fBinterp\fR \fBcreate \fR?\fB\-safe\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? Creates a slave interpreter identified by \fIpath\fR and a new command, called a \fIslave command\fR. The name of the slave command is the last component of \fIpath\fR. The new slave interpreter and the slave command are created in the interpreter identified by the path obtained by removing the last component from \fIpath\fR. For example, if \fIpath is \fBa b |
| ︙ | ︙ | |||
160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | \fBinterp\fR \fBeval\fR \fIpath arg \fR?\fIarg ...\fR? This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates the resulting string as a Tcl script in the slave interpreter identified by \fIpath\fR. The result of this evaluation (including error information such as the \fBerrorInfo\fR and \fBerrorCode\fR variables, if an error occurs) is returned to the invoking interpreter. .TP \fBinterp exists \fIpath\fR Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the invoking interpreter is used. .VS "" BR .TP \fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR? Makes the hidden command \fIhiddenName\fR exposed, eventually bringing it back under a new \fIexposedCmdName\fR name (this name is currently accepted only if it is a valid global name space name without any ::), in the interpreter denoted by \fIpath\fR. If an exposed command with the targeted name already exists, this command fails. | > > > > > | | | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | \fBinterp\fR \fBeval\fR \fIpath arg \fR?\fIarg ...\fR? This command concatenates all of the \fIarg\fR arguments in the same fashion as the \fBconcat\fR command, then evaluates the resulting string as a Tcl script in the slave interpreter identified by \fIpath\fR. The result of this evaluation (including error information such as the \fBerrorInfo\fR and \fBerrorCode\fR variables, if an error occurs) is returned to the invoking interpreter. Note that the script will be executed in the current context stack frame of the \fIpath\fR interpreter; this is so that the implementations (in a master interpreter) of aliases in a slave interpreter can execute scripts in the slave that find out information about the slave's current state and stack frame. .TP \fBinterp exists \fIpath\fR Returns \fB1\fR if a slave interpreter by the specified \fIpath\fR exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the invoking interpreter is used. .VS "" BR .TP \fBinterp expose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR? Makes the hidden command \fIhiddenName\fR exposed, eventually bringing it back under a new \fIexposedCmdName\fR name (this name is currently accepted only if it is a valid global name space name without any ::), in the interpreter denoted by \fIpath\fR. If an exposed command with the targeted name already exists, this command fails. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .TP \fBinterp\fR \fBhide\fR \fIpath\fR \fIexposedCmdName\fR ?\fIhiddenCmdName\fR? Makes the exposed command \fIexposedCmdName\fR hidden, renaming it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if \fIhiddenCmdName\fR is not given, in the interpreter denoted by \fIpath\fR. If a hidden command with the targeted name already exists, this command fails. Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can not contain namespace qualifiers, or an error is raised. Commands to be hidden by \fBinterp hide\fR are looked up in the global namespace even if the current namespace is not the global one. This prevents slaves from fooling a master interpreter into hiding the wrong command, by making the current namespace be different from the global one. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .TP \fBinterp\fR \fBhidden\fR \fIpath\fR Returns a list of the names of all hidden commands in the interpreter identified by \fIpath\fR. .TP \fBinterp\fR \fBinvokehidden\fR \fIpath\fR ?\fB-global\fR? \fIhiddenCmdName\fR ?\fIarg ...\fR? Invokes the hidden command \fIhiddenCmdName\fR with the arguments supplied in the interpreter denoted by \fIpath\fR. No substitutions or evaluation are applied to the arguments. If the \fB-global\fR flag is present, the hidden command is invoked at the global level in the target interpreter; otherwise it is invoked at the current call frame and can access local variables in that and outer call frames. Hidden commands are explained in more detail in \fBHIDDEN COMMANDS\fR, below. .VE .TP \fBinterp issafe\fR ?\fIpath\fR? Returns \fB1\fR if the interpreter identified by the specified \fIpath\fR is safe, \fB0\fR otherwise. .VS "" BR .TP |
| ︙ | ︙ | |||
265 266 267 268 269 270 271 | invoking interpreter or one of its descendants then an error is generated. The target command does not have to be defined at the time of this invocation. .TP \fBinterp\fR \fBtransfer\fR \fIsrcPath channelId destPath\fR Causes the IO channel identified by \fIchannelId\fR to become available in the interpreter identified by \fIdestPath\fR and unavailable in the interpreter identified by \fIsrcPath\fR. | < | | | | < | | | | | | | | > > > > > > > > | | | | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
invoking interpreter or one of its descendants then an error is generated.
The target command does not have to be defined at the time of this invocation.
.TP
\fBinterp\fR \fBtransfer\fR \fIsrcPath channelId destPath\fR
Causes the IO channel identified by \fIchannelId\fR to become available in
the interpreter identified by \fIdestPath\fR and unavailable in the
interpreter identified by \fIsrcPath\fR.
.SH "SLAVE COMMAND"
.PP
For each slave interpreter created with the \fBinterp\fR command, a
new Tcl command is created in the master interpreter with the same
name as the new interpreter. This command may be used to invoke
various operations on the interpreter. It has the following
general form:
.CS
\fIslave command \fR?\fIarg arg ...\fR?
.CE
\fISlave\fR is the name of the interpreter, and \fIcommand\fR
and the \fIarg\fRs determine the exact behavior of the command.
The valid forms of this command are:
.TP
\fIslave \fBaliases\fR
Returns a Tcl list whose elements are the tokens of all the
aliases in \fIslave\fR. The tokens correspond to the values returned when
the aliases were created (which may not be the same
as the current names of the commands).
.TP
\fIslave \fBalias \fIsrcToken\fR
Returns a Tcl list whose elements are the \fItargetCmd\fR and
\fIarg\fRs associated with the alias represented by \fIsrcToken\fR
(this is the value returned when the alias was
created; it is possible that the actual source command in the
slave is different from \fIsrcToken\fR).
.TP
\fIslave \fBalias \fIsrcToken \fB{}\fR
Deletes the alias for \fIsrcToken\fR in the slave interpreter.
\fIsrcToken\fR refers to the value returned when the alias
was created; if the source command has been renamed, the renamed
command will be deleted.
.TP
\fIslave \fBalias \fIsrcCmd targetCmd \fR?\fIarg ..\fR?
Creates an alias such that whenever \fIsrcCmd\fR is invoked
in \fIslave\fR, \fItargetCmd\fR is invoked in the master.
The \fIarg\fR arguments will be passed to \fItargetCmd\fR as additional
arguments, prepended before any arguments passed in the invocation of
\fIsrcCmd\fR.
See \fBALIAS INVOCATION\fR below for details.
The command returns a token that uniquely identifies the command created
\fIsrcCmd\fR, even if the command is renamed afterwards. The token may but
does not have to be equal to \fIsrcCmd\fR.
.TP
\fIslave \fBeval \fIarg \fR?\fIarg ..\fR?
This command concatenates all of the \fIarg\fR arguments in
the same fashion as the \fBconcat\fR command, then evaluates
the resulting string as a Tcl script in \fIslave\fR.
The result of this evaluation (including error information
such as the \fBerrorInfo\fR and \fBerrorCode\fR variables, if an
error occurs) is returned to the invoking interpreter.
Note that the script will be executed in the current context stack frame
of \fIslave\fR; this is so that the implementations (in a master
interpreter) of aliases in a slave interpreter can execute scripts in
the slave that find out information about the slave's current state
and stack frame.
.VS "" BR
.TP
\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
This command exposes the hidden command \fIhiddenName\fR, eventually bringing
it back under a new \fIexposedCmdName\fR name (this name is currently
accepted only if it is a valid global name space name without any ::),
in \fIslave\fR.
If an exposed command with the targeted name already exists, this command
fails.
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
This command hides the exposed command \fIexposedCmdName\fR, renaming it to
the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
argument is not given, in the \fIslave\fR interpreter.
If a hidden command with the targeted name already exists, this command
fails.
Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
not contain namespace qualifiers, or an error is raised.
Commands to be hidden are looked up in the global
namespace even if the current namespace is not the global one. This
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
For more details on hidden commands, see \fBHIDDEN COMMANDS\fR, below.
.TP
\fIslave \fBhidden\fR
Returns a list of the names of all hidden commands in \fIslave\fR.
.TP
\fIslave \fBinvokehidden\fR ?\fB-global\fR \fIhiddenName \fR?\fIarg ..\fR?
This command invokes the hidden command \fIhiddenName\fR with the
supplied arguments, in \fIslave\fR. No substitutions or evaluations are
applied to the arguments.
If the \fB-global\fR flag is given, the command is invoked at the global
level in the slave; otherwise it is invoked at the current call frame and
can access local variables in that or outer call frames.
For more details on hidden commands,
see \fBHIDDEN COMMANDS\fR, below.
.VE
.TP
\fIslave \fBissafe\fR
Returns \fB1\fR if the slave interpreter is safe, \fB0\fR otherwise.
.VS "" BR
.TP
\fIslave \fBmarktrusted\fR
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 | .DE .VS "" BR The following commands are hidden by \fBinterp create\fR when it creates a safe interpreter: .DS .ta 1.2i 2.4i 3.6i \fBcd encoding exec exit | | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | .DE .VS "" BR The following commands are hidden by \fBinterp create\fR when it creates a safe interpreter: .DS .ta 1.2i 2.4i 3.6i \fBcd encoding exec exit fconfigure file glob load open pwd socket source\fR .DE These commands can be recreated later as Tcl procedures or aliases, or re-exposed by \fBinterp expose\fR. .PP The following commands from Tcl's library of support procedures are not present in a safe interpreter: |
| ︙ | ︙ | |||
483 484 485 486 487 488 489 | If extensions are loaded into a safe interpreter, they may also restrict their own functionality to eliminate unsafe commands. For a discussion of management of extensions for safety see the manual entries for \fBSafe\-Tcl\fR and the \fBload\fR Tcl command. .PP A safe interpreter may not alter the recursion limit of any interpreter, including itself. | < | 498 499 500 501 502 503 504 505 506 507 508 509 510 511 | If extensions are loaded into a safe interpreter, they may also restrict their own functionality to eliminate unsafe commands. For a discussion of management of extensions for safety see the manual entries for \fBSafe\-Tcl\fR and the \fBload\fR Tcl command. .PP A safe interpreter may not alter the recursion limit of any interpreter, including itself. .SH "ALIAS INVOCATION" .PP The alias mechanism has been carefully designed so that it can be used safely when an untrusted script is executing in a safe slave and the target of the alias is a trusted master. The most important thing in guaranteeing safety is to ensure that information passed from the slave to the master is |
| ︙ | ︙ | |||
524 525 526 527 528 529 530 | .PP When writing the \fItargetCmd\fRs for aliases in safe interpreters, it is very important that the arguments to that command never be evaluated or substituted, since this would provide an escape mechanism whereby the slave interpreter could execute arbitrary code in the master. This in turn would compromise the security of the system. | < | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 | .PP When writing the \fItargetCmd\fRs for aliases in safe interpreters, it is very important that the arguments to that command never be evaluated or substituted, since this would provide an escape mechanism whereby the slave interpreter could execute arbitrary code in the master. This in turn would compromise the security of the system. .VS .SH "HIDDEN COMMANDS" .PP Safe interpreters greatly restrict the functionality available to Tcl programs executing within them. Allowing the untrusted Tcl program to have direct access to this functionality is unsafe, because it can be used for a variety of |
| ︙ | ︙ | |||
567 568 569 570 571 572 573 | the hidden command. .PP Because a master interpreter may invoke a hidden command as part of handling an alias invocation, great care must be taken to avoid evaluating any arguments passed in through the alias invocation. Otherwise, malicious slave interpreters could cause a trusted master interpreter to execute dangerous commands on their behalf. See the section | | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 | the hidden command. .PP Because a master interpreter may invoke a hidden command as part of handling an alias invocation, great care must be taken to avoid evaluating any arguments passed in through the alias invocation. Otherwise, malicious slave interpreters could cause a trusted master interpreter to execute dangerous commands on their behalf. See the section on \fBALIAS INVOCATION\fR for a more complete discussion of this topic. To help avoid this problem, no substitutions or evaluations are applied to arguments of \fBinterp invokehidden\fR. .PP Safe interpreters are not allowed to invoke hidden commands in themselves or in their descendants. This prevents safe slaves from gaining access to hidden functionality in themselves or their descendants. .PP |
| ︙ | ︙ | |||
598 599 600 601 602 603 604 605 606 607 608 609 610 | prevents slaves from fooling a master interpreter into hiding the wrong command, by making the current namespace be different from the global one. .VE .SH CREDITS .PP This mechanism is based on the Safe-Tcl prototype implemented by Nathaniel Borenstein and Marshall Rose. .SH "SEE ALSO" load(n), safe(n), Tcl_CreateSlave(3) .SH KEYWORDS alias, master interpreter, safe interpreter, slave interpreter | > > > > > > > > > > > > > > > > > > > > > | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 |
prevents slaves from fooling a master interpreter into hiding the wrong
command, by making the current namespace be different from the global one.
.VE
.SH CREDITS
.PP
This mechanism is based on the Safe-Tcl prototype implemented
by Nathaniel Borenstein and Marshall Rose.
.SH EXAMPLES
Creating and using an alias for a command in the current interpreter:
.CS
\fBinterp alias\fR {} getIndex {} lsearch {alpha beta gamma delta}
set idx [getIndex delta]
.CE
.PP
Executing an arbitrary command in a safe interpreter where every
invokation of \fBlappend\fR is logged:
.CS
set i [\fBinterp create\fR -safe]
\fBinterp hide\fR $i lappend
\fBinterp alias\fR $i lappend {} loggedLappend $i
proc loggedLappend {i args} {
puts "logged invokation of lappend $args"
# Be extremely careful about command construction
eval [linsert $args 0 \\
\fBinterp invokehidden\fR $i lappend]
}
\fBinterp eval\fR $i $someUntrustedScript
.CE
.SH "SEE ALSO"
load(n), safe(n), Tcl_CreateSlave(3)
.SH KEYWORDS
alias, master interpreter, safe interpreter, slave interpreter
|
Changes to doc/join.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | > > > > > > > > > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: join.n,v 1.3.18.1 2004/10/27 12:52:40 dkf Exp $
'\"
.so man.macros
.TH join n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
join \- Create a string by joining together list elements
.SH SYNOPSIS
\fBjoin \fIlist \fR?\fIjoinString\fR?
.BE
.SH DESCRIPTION
.PP
The \fIlist\fR argument must be a valid Tcl list.
This command returns the string
formed by joining all of the elements of \fIlist\fR together with
\fIjoinString\fR separating each adjacent pair of elements.
The \fIjoinString\fR argument defaults to a space character.
.SH EXAMPLES
Making a comma-separated list:
.CS
set data {1 2 3 4 5}
\fBjoin\fR $data ", "
\fB=> 1, 2, 3, 4, 5\fR
.CE
.PP
Using \fBjoin\fR to flatten a list by a single level:
.CS
set data {1 {2 3} 4 {5 {6 7} 8}}
\fBjoin\fR $data
\fB=> 1 2 3 4 5 {6 7} 8\fR
.CE
.SH "SEE ALSO"
list(n), lappend(n), split(n)
.SH KEYWORDS
element, join, list, separator
|
Changes to doc/lappend.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lappend.n,v 1.6.4.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH lappend n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lappend \- Append list elements onto a variable |
| ︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | given by the \fIvalue\fR arguments. \fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs are appended as list elements rather than raw text. This command provides a relatively efficient way to build up large lists. For example, ``\fBlappend a $b\fR'' is much more efficient than ``\fBset a [concat $a [list $b]]\fR'' when \fB$a\fR is long. .SH "SEE ALSO" list(n), lindex(n), linsert(n), llength(n), .VS 8.4 lset(n) .VE lsort(n), lrange(n) .SH KEYWORDS append, element, list, variable | > > > > > > > > > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | given by the \fIvalue\fR arguments. \fBLappend\fR is similar to \fBappend\fR except that the \fIvalue\fRs are appended as list elements rather than raw text. This command provides a relatively efficient way to build up large lists. For example, ``\fBlappend a $b\fR'' is much more efficient than ``\fBset a [concat $a [list $b]]\fR'' when \fB$a\fR is long. .SH EXAMPLE Using \fBlappend\fR to build up a list of numbers. .CS % set var 1 1 % \fBlappend\fR var 2 1 2 % \fBlappend\fR var 3 4 5 1 2 3 4 5 .CE .SH "SEE ALSO" list(n), lindex(n), linsert(n), llength(n), .VS 8.4 lset(n) .VE lsort(n), lrange(n) .SH KEYWORDS append, element, list, variable |
Changes to doc/lindex.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lindex.n,v 1.7.4.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH lindex n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lindex \- Retrieve an element from a list |
| ︙ | ︙ | |||
65 66 67 68 69 70 71 | .CE is synonymous with .CS lindex [lindex [lindex $a 1] 2] 3 .CE .SH EXAMPLES .CS | | | | | | | | | | | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
.CE
is synonymous with
.CS
lindex [lindex [lindex $a 1] 2] 3
.CE
.SH EXAMPLES
.CS
\fBlindex\fR {a b c} \fI=> a b c\fR
\fBlindex\fR {a b c} {} \fI=> a b c\fR
\fBlindex\fR {a b c} 0 \fI=> a\fR
\fBlindex\fR {a b c} 2 \fI=> c\fR
\fBlindex\fR {a b c} end \fI=> c\fR
\fBlindex\fR {a b c} end-1 \fI=> b\fR
\fBlindex\fR {{a b c} {d e f} {g h i}} 2 1 \fI=> h\fR
\fBlindex\fR {{a b c} {d e f} {g h i}} {2 1} \fI=> h\fR
\fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} 1 1 0 \fI=> g\fR
\fBlindex\fR {{{a b} {c d}} {{e f} {g h}}} {1 1 0} \fI=> g\fR
.CE
.VE
.SH "SEE ALSO"
list(n), lappend(n), linsert(n), llength(n), lsearch(n),
.VS 8.4
lset(n),
.VE
lsort(n),
lrange(n), lreplace(n)
.SH KEYWORDS
element, index, list
|
Changes to doc/linsert.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: linsert.n,v 1.7.4.1 2004/10/27 12:52:40 dkf Exp $
'\"
.so man.macros
.TH linsert n 8.2 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
linsert \- Insert elements into a list
.SH SYNOPSIS
\fBlinsert \fIlist index element \fR?\fIelement element ...\fR?
.BE
.SH DESCRIPTION
.PP
This command produces a new list from \fIlist\fR by inserting all of the
\fIelement\fR arguments just before the \fIindex\fR'th element of
\fIlist\fR. Each \fIelement\fR argument will become a separate element of
the new list. If \fIindex\fR is less than or equal to zero, then the new
elements are inserted at the beginning of the list. If \fIindex\fR has the
value \fBend\fR, or if it is greater than or equal to the number of
elements in the list, then the new elements are appended to the list.
\fBend\-\fIinteger\fR refers to the last element in the list minus the
specified integer offset.
.SH EXAMPLE
Putting some values into a list, first indexing from the start and
then indexing from the end, and then chaining them together:
.CS
set oldList {the fox jumps over the dog}
set midList [\fBlinsert\fR $oldList 1 quick]
set newList [\fBlinsert\fR $midList end-1 lazy]
# The old lists still exist though...
set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy]
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), llength(n), lsearch(n),
lset(n), lsort(n), lrange(n), lreplace(n)
.VE
.SH KEYWORDS
element, insert, list
|
Changes to doc/list.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: list.n,v 1.7.4.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH list n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME list \- Create a list |
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | Braces and backslashes get added as necessary, so that the \fBlindex\fR command may be used on the result to re-extract the original arguments, and also so that \fBeval\fR may be used to execute the resulting list, with \fIarg1\fR comprising the command's name and the other \fIarg\fRs comprising its arguments. \fBList\fR produces slightly different results than \fBconcat\fR: \fBconcat\fR removes one level of grouping before forming the list, while \fBlist\fR works directly from the original arguments. | > | | | | > | | < | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
Braces and backslashes get added as necessary, so that the \fBlindex\fR command
may be used on the result to re-extract the original arguments, and also
so that \fBeval\fR may be used to execute the resulting list, with
\fIarg1\fR comprising the command's name and the other \fIarg\fRs comprising
its arguments. \fBList\fR produces slightly different results than
\fBconcat\fR: \fBconcat\fR removes one level of grouping before forming
the list, while \fBlist\fR works directly from the original arguments.
.SH EXAMPLE
The command
.CS
\fBlist\fR a b "c d e " " f {g h}"
.CE
will return
.CS
\fBa b {c d e } { f {g h}}\fR
.CE
while \fBconcat\fR with the same arguments will return
.CS
\fBa b c d e f {g h}\fR
.CE
.SH "SEE ALSO"
lappend(n), lindex(n), linsert(n), llength(n), lrange(n),
lreplace(n), lsearch(n),
.VS 8.4
lset(n),
.VE 8.4
lsort(n)
.SH KEYWORDS
element, list
|
Changes to doc/llength.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
'\" RCS: @(#) $Id: llength.n,v 1.6.4.1 2004/10/27 12:52:40 dkf Exp $
'\"
.so man.macros
.TH llength n "" Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
llength \- Count the number of elements in a list
.SH SYNOPSIS
\fBllength \fIlist\fR
.BE
.SH DESCRIPTION
.PP
Treats \fIlist\fR as a list and returns a decimal string giving
the number of elements in it.
.SH EXAMPLES
The result is the number of elements:
.CS
% \fBllength\fR {a b c d e}
5
% \fBllength\fR {a b c}
3
% \fBllength\fR {}
0
.CE
.PP
Elements are not guaranteed to be exactly words in a dictionary sense
of course, especially when quoting is used:
.CS
% \fBllength\fR {a b {c d} e}
4
% \fBllength\fR {a b { } c d e}
6
.CE
.PP
An empty list is not necessarily an empty string:
.CS
% set var { }; puts "[string length $var],[\fBllength\fR $var]"
1,0
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), lsearch(n),
lset(n), lsort(n), lrange(n), lreplace(n)
.VE
.SH KEYWORDS
element, list, length
|
Changes to doc/load.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: load.n,v 1.7.2.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH load n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME load \- Load machine code and initialize new commands. |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 | (one that has been registered by calling the \fBTcl_StaticPackage\fR procedure) by that name; if one is found, it is used. Otherwise, the \fBload\fR command searches for a dynamically loaded package by that name, and uses it if it is found. If several different files have been \fBload\fRed with different versions of the package, Tcl picks the file that was loaded first. .VE | < | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
(one that has been registered by calling the \fBTcl_StaticPackage\fR
procedure) by that name; if one is found, it is used.
Otherwise, the \fBload\fR command searches for a dynamically loaded
package by that name, and uses it if it is found. If several
different files have been \fBload\fRed with different versions of
the package, Tcl picks the file that was loaded first.
.VE
.SH "PORTABILITY ISSUES"
.TP
\fBWindows\fR\0\0\0\0\0
.
When a load fails with "library not found" error, it is also possible
that a dependent library was not found. To see the dependent libraries,
type ``dumpbin -imports <dllname>'' in a DOS console to see what the
library must import.
When loading a DLL in the current directory, Windows will ignore ``./'' as
a path specifier and use a search heuristic to find the DLL instead.
To avoid this, load the DLL with:
.CS
\fBload\fR [file join [pwd] mylib.DLL]
.CE
.SH BUGS
.PP
If the same file is \fBload\fRed by different \fIfileName\fRs, it will
be loaded into the process's address space multiple times. The
behavior of this varies from system to system (some systems may
detect the redundant loads, others may not).
.SH EXAMPLE
The following is a minimal extension:
.PP
.CS
#include <tcl.h>
#include <stdio.h>
static int fooCmd(ClientData clientData,
Tcl_Interp *interp, int objc, char * CONST objv[]) {
printf("called with %d arguments\\n", objc);
return TCL_OK;
}
int Foo_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
return TCL_ERROR;
}
printf("creating foo command");
Tcl_CreateObjCommand(interp, "foo", fooCmd, NULL, NULL);
return TCL_OK;
}
.CE
.PP
When built into a shared/dynamic library with a suitable name
(e.g. \fBfoo.dll\fR on Windows, \fBlibfoo.so\fR on Solaris and Linux)
it can then be loaded into Tcl with the following:
.PP
.CS
# Load the extension
switch $tcl_platform(platform) {
windows {
\fBload\fR ./foo.dll
}
unix {
\fBload\fR ./libfoo[info sharedlibextension]
}
}
# Now execute the command defined by the extension
foo
.CE
.SH "SEE ALSO"
info sharedlibextension, Tcl_StaticPackage(3), safe(n)
.SH KEYWORDS
binary code, loading, safe interpreter, shared library
|
Changes to doc/lrange.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lrange.n,v 1.6.4.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH lrange n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lrange \- Return one or more adjacent elements from a list |
| ︙ | ︙ | |||
31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | in the list, then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty string is returned. Note: ``\fBlrange \fIlist first first\fR'' does not always produce the same result as ``\fBlindex \fIlist first\fR'' (although it often does for simple fields that aren't enclosed in braces); it does, however, produce exactly the same results as ``\fBlist [lindex \fIlist first\fB]\fR'' .SH "SEE ALSO" .VS 8.4 list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), lset(n), lreplace(n), lsort(n) .VE .SH KEYWORDS element, list, range, sublist | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
in the list, then it is treated as if it were \fBend\fR.
If \fIfirst\fR is greater than \fIlast\fR then an empty string
is returned.
Note: ``\fBlrange \fIlist first first\fR'' does not always produce the
same result as ``\fBlindex \fIlist first\fR'' (although it often does
for simple fields that aren't enclosed in braces); it does, however,
produce exactly the same results as ``\fBlist [lindex \fIlist first\fB]\fR''
.SH EXAMPLES
Selecting the first two elements:
.CS
% \fBlrange\fR {a b c d e} 0 1
a b
.CE
.PP
Selecting the last three elements:
.CS
% \fBlrange\fR {a b c d e} end-2 end
c d e
.CE
.PP
Selecting everything except the first and last element:
.CS
% \fBlrange\fR {a b c d e} 1 end-1
b c d
.CE
.PP
Selecting a single element with \fBlrange\fR is not the same as doing
so with \fBlindex\fR:
.CS
% set var {some {elements to} select}
some {elements to} select
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lreplace(n), lsort(n)
.VE
.SH KEYWORDS
element, list, range, sublist
|
Changes to doc/lreplace.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lreplace.n,v 1.8.4.1 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH lreplace n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lreplace \- Replace elements in a list with new elements |
| ︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | The \fIelement\fR arguments specify zero or more new arguments to be added to the list in place of those that were deleted. Each \fIelement\fR argument will become a separate element of the list. If no \fIelement\fR arguments are specified, then the elements between \fIfirst\fR and \fIlast\fR are simply deleted. If \fIlist\fR is empty, any \fIelement\fR arguments are added to the end of the list. .SH "SEE ALSO" .VS 8.4 list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n), lset(n), lrange(n), lsort(n) .VE .SH KEYWORDS element, list, replace | > > > > > > > > > > > > > > > > > > > > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
The \fIelement\fR arguments specify zero or more new arguments to
be added to the list in place of those that were deleted.
Each \fIelement\fR argument will become a separate element of
the list. If no \fIelement\fR arguments are specified, then the elements
between \fIfirst\fR and \fIlast\fR are simply deleted. If \fIlist\fR
is empty, any \fIelement\fR arguments are added to the end of the list.
.SH EXAMPLES
Replacing an element of a list with another:
.CS
% \fBlreplace\fR {a b c d e} 1 1 foo
a foo c d e
.CE
.PP
Replacing two elements of a list with three:
.CS
% \fBlreplace\fR {a b c d e} 1 2 three more elements
a three more elements d e
.CE
.PP
Deleting the last element from a list in a variable:
.CS
% set var {a b c d e}
a b c d e
% set var [\fBlreplace\fR $var end end]
a b c d
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lrange(n), lsort(n)
.VE
.SH KEYWORDS
element, list, replace
|
Changes to doc/lsearch.n.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lsearch.n,v 1.13.2.4 2005/01/05 21:53:30 dkf Exp $ '\" .so man.macros .TH lsearch n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsearch \- See if a list contains a particular element |
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | \fB\-all\fR .VS 8.4 Changes the result to be the list of all matching indices (or all matching values if \fB\-inline\fR is specified as well.) .VE 8.4 .TP \fB\-ascii\fR | | > | > | > | > | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | \fB\-all\fR .VS 8.4 Changes the result to be the list of all matching indices (or all matching values if \fB\-inline\fR is specified as well.) .VE 8.4 .TP \fB\-ascii\fR The list elements are to be examined as Unicode strings (the name is for backward-compatability reasons.) This option is only meaningful when used with \fB\-exact\fR or \fB\-sorted\fR. .TP \fB\-decreasing\fR The list elements are sorted in decreasing order. This option is only meaningful when used with \fB\-sorted\fR. .TP \fB\-dictionary\fR The list elements are to be compared using dictionary-style comparisons (see \fBlsort\fR for a fuller description). This option is only meaningful when used with \fB\-exact\fR or \fB\-sorted\fR, and it is only distinguishable from the \fB\-ascii\fR option when the \fB\-sorted\fR option is given, because values are only dictionary-equal when exactly equal. .TP \fB\-exact\fR The list element must contain exactly the same string as \fIpattern\fR. .TP \fB\-glob\fR \fIPattern\fR is a glob-style pattern which is matched against each list element using the same rules as the \fBstring match\fR command. |
| ︙ | ︙ | |||
111 112 113 114 115 116 117 | last takes precedence. If more than one of \fB\-increasing\fR and \fB\-decreasing\fR is specified, the option specified last takes precedence. .VS 8.4 .SH EXAMPLES .CS | | | | | | | | > > > > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
last takes precedence. If more than one of \fB\-increasing\fR and
\fB\-decreasing\fR is specified, the option specified last takes
precedence.
.VS 8.4
.SH EXAMPLES
.CS
\fBlsearch\fR {a b c d e} c \fI=> 2\fR
\fBlsearch\fR -all {a b c a b c} c \fI=> 2 5\fR
\fBlsearch\fR -inline {a20 b35 c47} b* \fI=> b35\fR
\fBlsearch\fR -inline -not {a20 b35 c47} b* \fI=> a20\fR
\fBlsearch\fR -all -inline -not {a20 b35 c47} b* \fI=> a20 c47\fR
\fBlsearch\fR -all -not {a20 b35 c47} b* \fI=> 0 2\fR
\fBlsearch\fR -start 3 {a b c a b c} c \fI=> 5\fR
.CE
.VE 8.4
.SH "SEE ALSO"
.VS 8.4
foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n),
lset(n), lsort(n), lrange(n), lreplace(n)
.VE
.SH KEYWORDS
list, match, pattern, regular expression, search, string
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/lset.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lset.n,v 1.6.2.1 2003/12/01 21:29:34 msofer Exp $ '\" .so man.macros .TH lset n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lset \- Change an element in a list |
| ︙ | ︙ | |||
33 34 35 36 37 38 39 |
.CS
lset varName {} newValue
.CE
In this case, \fInewValue\fR replaces the old value of the variable
\fIvarName\fR.
.PP
When presented with a single index, the \fBlset\fR command
| | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
.CS
lset varName {} newValue
.CE
In this case, \fInewValue\fR replaces the old value of the variable
\fIvarName\fR.
.PP
When presented with a single index, the \fBlset\fR command
treats the content of the \fIvarName\fR variable as a Tcl list.
It addresses the \fIindex\fR'th element in it
(0 refers to the first element of the list).
When interpreting the list, \fBlset\fR observes the same rules
concerning braces and quotes and backslashes as the Tcl command
interpreter; however, variable
substitution and command substitution do not occur.
The command constructs a new list in which the designated element is
|
| ︙ | ︙ |
Changes to doc/lsort.n.
1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" Copyright (c) 2001 Kevin B. Kenny. All rights reserved. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: lsort.n,v 1.12.4.2 2004/10/27 12:52:40 dkf Exp $ '\" .so man.macros .TH lsort n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME lsort \- Sort the elements of a list |
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | .PP By default ASCII sorting is used with the result returned in increasing order. However, any of the following options may be specified before \fIlist\fR to control the sorting process (unique abbreviations are accepted): .TP 20 \fB\-ascii\fR | | > | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | .PP By default ASCII sorting is used with the result returned in increasing order. However, any of the following options may be specified before \fIlist\fR to control the sorting process (unique abbreviations are accepted): .TP 20 \fB\-ascii\fR Use string comparison with Unicode code-point collation order (the name is for backward-compatibility reasons.) This is the default. .TP 20 \fB\-dictionary\fR Use dictionary-style comparison. This is the same as \fB\-ascii\fR except (a) case is ignored except as a tie-breaker and (b) if two strings contain embedded numbers, the numbers compare as integers, not characters. For example, in \fB\-dictionary\fR mode, \fBbigBoy\fR sorts between \fBbigbang\fR and \fBbigboy\fR, and \fBx10y\fR |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
\fB\-unique\fR
If this option is specified, then only the last set of duplicate
elements found in the list will be retained. Note that duplicates are
determined relative to the comparison used in the sort. Thus if
\fI-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be
considered duplicates and only the second element, \fB{1 b}\fR, would
be retained.
| < < < | < | < | | < | | < | | | < | < | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
\fB\-unique\fR
If this option is specified, then only the last set of duplicate
elements found in the list will be retained. Note that duplicates are
determined relative to the comparison used in the sort. Thus if
\fI-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be
considered duplicates and only the second element, \fB{1 b}\fR, would
be retained.
.SH "NOTES"
.PP
The options to \fBlsort\fR only control what sort of comparison is
used, and do not necessarily constrain what the values themselves
actually are. This distinction is only noticeable when the list to be
sorted has fewer than two elements.
.PP
The \fBlsort\fR command is reentrant, meaning it is safe to use as
part of the implementation of a command used in the \fB\-command\fR
option.
.SH "EXAMPLES"
.PP
Sorting a list using ASCII sorting:
.CS
% \fBlsort\fR {a10 B2 b1 a1 a2}
B2 a1 a10 a2 b1
.CE
.PP
Sorting a list using Dictionary sorting:
.CS
% \fBlsort\fR -dictionary {a10 B2 b1 a1 a2}
a1 a2 a10 b1 B2
.CE
.PP
Sorting lists of integers:
.CS
% \fBlsort\fR -integer {5 3 1 2 11 4}
1 2 3 4 5 11
% \fBlsort\fR -integer {1 2 0x5 7 0 4 -1}
-1 0 1 2 4 0x5 7
.CE
.PP
Sorting lists of floating-point numbers:
.CS
% \fBlsort\fR -real {5 3 1 2 11 4}
1 2 3 4 5 11
% \fBlsort\fR -real {.5 0.07e1 0.4 6e-1}
0.4 .5 6e-1 0.07e1
.CE
.PP
Sorting using indices:
.CS
% # Note the space character before the c
% \fBlsort\fR {{a 5} { c 3} {b 4} {e 1} {d 2}}
{ c 3} {a 5} {b 4} {d 2} {e 1}
% \fBlsort\fR -index 0 {{a 5} { c 3} {b 4} {e 1} {d 2}}
{a 5} {b 4} { c 3} {d 2} {e 1}
% \fBlsort\fR -index 1 {{a 5} { c 3} {b 4} {e 1} {d 2}}
{e 1} {d 2} { c 3} {b 4} {a 5}
.CE
.PP
Stripping duplicate values using sorting:
.CS
% \fBlsort\fR -unique {a b c a b c a b c}
a b c
.CE
.PP
More complex sorting using a comparison function:
.CS
% proc compare {a b} {
set a0 [lindex $a 0]
set b0 [lindex $b 0]
if {$a0 < $b0} {
return -1
} elseif {$a0 > $b0} {
return 1
}
return [string compare [lindex $a 1] [lindex $b 1]]
}
% \fBlsort\fR -command compare \\
{{3 apple} {0x2 carrot} {1 dingo} {2 banana}}
{1 dingo} {2 banana} {0x2 carrot} {3 apple}
.CE
.SH "SEE ALSO"
.VS 8.4
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lset(n), lrange(n), lreplace(n)
.VE
.SH KEYWORDS
element, list, order, sort
|
Changes to doc/msgcat.n.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.2\fR .sp | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.2\fR .sp \fBpackage require msgcat 1.3.4\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? .sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | the application source code. New languages or locales are provided by adding a new file to the message catalog. .PP Use of the message catalog is optional by any application or package, but is encouraged if the application or package wishes to be enabled for multi-lingual applications. | < | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | the application source code. New languages or locales are provided by adding a new file to the message catalog. .PP Use of the message catalog is optional by any application or package, but is encouraged if the application or package wishes to be enabled for multi-lingual applications. .SH COMMANDS .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? Returns a translation of \fIsrc-string\fR according to the user's current locale. If additional arguments past \fIsrc-string\fR are given, the \fBformat\fR command is used to substitute the additional arguments in the translation of \fIsrc-string\fR. .PP \fB::msgcat::mc\fR will search the messages defined in the current namespace for a translation of \fIsrc-string\fR; if none is found, it will search in the parent of the current namespace, and so on until it reaches the global namespace. If no translation string exists, \fB::msgcat::mcunknown\fR is called and the string returned from \fB::msgcat::mcunknown\fR is returned. .PP |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | below for a description of the locale string format. .TP \fB::msgcat::mcpreferences\fR Returns an ordered list of the locales preferred by the user, based on the user's language specification. The list is ordered from most specific to least preference. The list is derived from the current | | | | | | | < | | < | | > > | | | | | | | | > | | | < | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
below for a description of the locale string format.
.TP
\fB::msgcat::mcpreferences\fR
Returns an ordered list of the locales preferred by
the user, based on the user's language specification.
The list is ordered from most specific to least
preference. The list is derived from the current
locale set in msgcat by \fB::msgcat::mclocale\fR, and
cannot be set independently. For example, if the
current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR
returns \fB{en_US_funky en_US en}\fR.
.TP
\fB::msgcat::mcload \fIdirname\fR
Searches the specified directory for files that match
the language specifications returned by \fB::msgcat::mcpreferences\fR
(note that these are all lowercase), extended by the file
extension ``.msg''. Each matching file is
read in order, assuming a UTF-8 encoding. The file contents are
then evaluated as a Tcl script. This means that Unicode characters
may be present in the message file either directly in their UTF-8
encoded form, or by use of the backslash-u quoting recognized by Tcl
evaluation. The number of message files which matched the specification
and were loaded is returned.
.TP
\fB::msgcat::mcset \fIlocale src-string \fR?\fItranslate-string\fR?
Sets the translation for \fIsrc-string\fR to \fItranslate-string\fR
in the specified \fIlocale\fR and the current namespace. If
\fItranslate-string\fR is not specified, \fIsrc-string\fR is used
for both. The function returns \fItranslate-string\fR.
.TP
\fB::msgcat::mcmset \fIlocale src-trans-list\fR
Sets the translation for multiple source strings in
\fIsrc-trans-list\fR in the specified \fIlocale\fR and the current
namespace.
\fIsrc-trans-list\fR must have an even number of elements and is in
the form {\fIsrc-string translate-string\fR ?\fIsrc-string
translate-string ...\fR?} \fB::msgcat::mcmset\fR can be significantly
faster than multiple invocations of \fB::msgcat::mcset\fR. The function
returns the number of translations set.
.TP
\fB::msgcat::mcunknown \fIlocale src-string\fR
This routine is called by \fB::msgcat::mc\fR in the case when
a translation for \fIsrc-string\fR is not defined in the
current locale. The default action is to return
\fIsrc-string\fR. This procedure can be redefined by the
application, for example to log error messages for each unknown
string. The \fB::msgcat::mcunknown\fR procedure is invoked at the
same stack context as the call to \fB::msgcat::mc\fR. The return value
of \fB::msgcat::mcunknown\fR is used as the return value for the call
to \fB::msgcat::mc\fR.
.SH "LOCALE SPECIFICATION"
.PP
The locale is specified to \fBmsgcat\fR by a locale string
passed to \fB::msgcat::mclocale\fR.
The locale string consists of
a language code, an optional country code, and an optional
system-specific code, each separated by ``_''. The country and language
codes are specified in standards ISO-639 and ISO-3166.
For example, the locale ``en'' specifies English and ``en_US'' specifies
U.S. English.
.PP
When the msgcat package is first loaded, the locale is initialized
according to the user's environment. The variables \fBenv(LC_ALL)\fR,
\fBenv(LC_MESSAGES)\fR, and \fBenv(LANG)\fR are examined in order.
The first of them to have a non-empty value is used to determine the
initial locale. The value is parsed according to the XPG4 pattern
.CS
language[_country][.codeset][@modifier]
.CE
to extract its parts. The initial locale is then set by calling
\fB::msgcat::mclocale\fR with the argument
.CS
language[_country][_modifier]
.CE
On Windows, if none of those environment variables is set, msgcat will
attempt to extract locale information from the
registry. If all these attempts to discover an initial locale
from the user's environment fail, msgcat defaults to an initial
locale of ``C''.
.PP
When a locale is specified by the user, a ``best match'' search is
performed during string translation. For example, if a user specifies
en_GB_Funky, the locales ``en_GB_Funky'', ``en_GB'', and ``en'' are
searched in order until a matching translation string is found. If no
translation string is available, then \fB::msgcat::mcunknown\fR is
called.
.SH "NAMESPACES AND MESSAGE CATALOGS"
.PP
Strings stored in the message catalog are stored relative
to the namespace from which they were added. This allows
multiple packages to use the same strings without fear
of collisions with other packages. It also allows the
source string to be shorter and less prone to typographical
error.
.PP
For example, executing the code
.CS
\fB::msgcat::mcset\fR en hello "hello from ::"
namespace eval foo {
\fB::msgcat::mcset\fR en hello "hello from ::foo"
}
puts [\fB::msgcat::mc\fR hello]
namespace eval foo {puts [\fB::msgcat::mc\fR hello]}
.CE
will print
.CS
hello from ::
hello from ::foo
.CE
.PP
When searching for a translation of a message, the
message catalog will search first the current namespace,
then the parent of the current namespace, and so on until
the global namespace is reached. This allows child namespaces
to "inherit" messages from their parent namespace.
.PP
For example, executing (in the ``en'' locale) the code
.CS
\fB::msgcat::mcset\fR en m1 ":: message1"
\fB::msgcat::mcset\fR en m2 ":: message2"
\fB::msgcat::mcset\fR en m3 ":: message3"
namespace eval ::foo {
\fB::msgcat::mcset\fR en m2 "::foo message2"
\fB::msgcat::mcset\fR en m3 "::foo message3"
}
namespace eval ::foo::bar {
\fB::msgcat::mcset\fR en m3 "::foo::bar message3"
}
namespace import \fB::msgcat::mc\fR
puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"
namespace eval ::foo {puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"}
namespace eval ::foo::bar {puts "[\fBmc\fR m1]; [\fBmc\fR m2]; [\fBmc\fR m3]"}
.CE
will print
.CS
:: message1; :: message2; :: message3
:: message1; ::foo message2; ::foo message3
:: message1; ::foo message2; ::foo::bar message3
.CE
.SH "LOCATION AND FORMAT OF MESSAGE FILES"
.PP
Message files can be located in any directory, subject
to the following conditions:
.IP [1]
All message files for a package are in the same directory.
.IP [2]
|
| ︙ | ︙ | |||
240 241 242 243 244 245 246 |
The file contains a series of calls to \fBmcset\fR and
\fBmcmset\fR, setting the necessary translation strings
for the language, likely enclosed in a \fBnamespace eval\fR
so that all source strings are tied to the namespace of
the package. For example, a short \fBes.msg\fR might contain:
.CS
namespace eval ::mypackage {
| | < | < | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
The file contains a series of calls to \fBmcset\fR and
\fBmcmset\fR, setting the necessary translation strings
for the language, likely enclosed in a \fBnamespace eval\fR
so that all source strings are tied to the namespace of
the package. For example, a short \fBes.msg\fR might contain:
.CS
namespace eval ::mypackage {
\fB::msgcat::mcset\fR es "Free Beer!" "Cerveza Gracias!"
}
.CE
.SH "RECOMMENDED MESSAGE SETUP FOR PACKAGES"
.PP
If a package is installed into a subdirectory of the
\fBtcl_pkgPath\fR and loaded via \fBpackage require\fR, the
following procedure is recommended.
.IP [1]
During package installation, create a subdirectory
\fBmsgs\fR under your package directory.
.IP [2]
Copy your *.msg files into that directory.
.IP [3]
Add the following command to your package
initialization script:
.CS
# load language files, stored in msgs subdirectory
\fB::msgcat::mcload\fR [file join [file dirname [info script]] msgs]
.CE
.SH "POSITIONAL CODES FOR FORMAT AND SCAN COMMANDS"
.PP
It is possible that a message string used as an argument
to \fBformat\fR might have positionally dependent parameters that
might need to be repositioned. For example, it might be
syntactically desirable to rearrange the sentence structure
while translating.
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 | .CS format "We produced %1\\$d units in location %2\\$s" $num $city format "In location %2\\$s we produced %1\\$d units" $num $city .CE .PP Similarly, positional parameters can be used with \fBscan\fR to extract values from internationalized strings. | < | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | .CS format "We produced %1\\$d units in location %2\\$s" $num $city format "In location %2\\$s we produced %1\\$d units" $num $city .CE .PP Similarly, positional parameters can be used with \fBscan\fR to extract values from internationalized strings. .SH CREDITS .PP The message catalog code was developed by Mark Harrison. .SH "SEE ALSO" format(n), scan(n), namespace(n), package(n) .SH KEYWORDS internationalization, i18n, localization, l10n, message, text, translation |
Changes to doc/namespace.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: namespace.n,v 1.9.2.2 2005/05/12 16:23:11 dgp Exp $ '\" .so man.macros .TH namespace n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME namespace \- create and manipulate contexts for commands and variables .SH SYNOPSIS \fBnamespace \fR?\fIoption\fR? ?\fIarg ...\fR? .BE .SH DESCRIPTION .PP The \fBnamespace\fR command lets you create, access, and destroy separate contexts for commands and variables. See the section \fBWHAT IS A NAMESPACE?\fR below for a brief overview of namespaces. The legal values of \fIoption\fR are listed below. Note that you can abbreviate the \fIoption\fRs. .TP \fBnamespace children \fR?\fInamespace\fR? ?\fIpattern\fR? Returns a list of all child namespaces that belong to the namespace \fInamespace\fR. If \fInamespace\fR is not specified, then the children are returned for the current namespace. This command returns fully-qualified names, which start with a double colon (\fB::\fR). If the optional \fIpattern\fR is given, then this command returns only the names that match the glob-style pattern. The actual pattern used is determined as follows: a pattern that starts with double colon (\fB::\fR) is used directly, otherwise the namespace \fInamespace\fR (or the fully-qualified name of the current namespace) is prepended onto the pattern. .TP \fBnamespace code \fIscript\fR Captures the current namespace context for later execution of the script \fIscript\fR. It returns a new script in which \fIscript\fR has been wrapped in a \fBnamespace inscope\fR command. The new script has two important properties. |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
and will have the same effect as the command
\fB::namespace eval ::a::b {foo bar x y}\fR.
This command is needed because
extensions like Tk normally execute callback scripts
in the global namespace.
A scoped command captures a command together with its namespace context
in a way that allows it to be executed properly later.
| | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
and will have the same effect as the command
\fB::namespace eval ::a::b {foo bar x y}\fR.
This command is needed because
extensions like Tk normally execute callback scripts
in the global namespace.
A scoped command captures a command together with its namespace context
in a way that allows it to be executed properly later.
See the section \fBSCOPED SCRIPTS\fR for some examples
of how this is used to create callback scripts.
.TP
\fBnamespace current\fR
Returns the fully-qualified name for the current namespace.
The actual name of the global namespace is ``''
(i.e., an empty string),
but this command returns \fB::\fR for the global namespace
|
| ︙ | ︙ | |||
125 126 127 128 129 130 131 | If no \fIpattern\fRs are given and the \-\fBclear\fR flag isn't given, this command returns the namespace's current export list. .TP \fBnamespace forget \fR?\fIpattern pattern ...\fR? Removes previously imported commands from a namespace. Each \fIpattern\fR is a simple or qualified name such as \fBx\fR, \fBfoo::x\fR or \fBa::b::p*\fR. | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | If no \fIpattern\fRs are given and the \-\fBclear\fR flag isn't given, this command returns the namespace's current export list. .TP \fBnamespace forget \fR?\fIpattern pattern ...\fR? Removes previously imported commands from a namespace. Each \fIpattern\fR is a simple or qualified name such as \fBx\fR, \fBfoo::x\fR or \fBa::b::p*\fR. Qualified names contain double colons (\fB::\fR) and qualify a name with the name of one or more namespaces. Each \fIqualified pattern\fR is qualified with the name of an exporting namespace and may have glob-style special characters in the command name at the end of the qualified name. Glob characters may not appear in a namespace name. For each \fIsimple pattern\fR this command deletes the matching |
| ︙ | ︙ | |||
207 208 209 210 211 212 213 | Returns the fully-qualified name of the parent namespace for namespace \fInamespace\fR. If \fInamespace\fR is not specified, the fully-qualified name of the current namespace's parent is returned. .TP \fBnamespace qualifiers\fR \fIstring\fR Returns any leading namespace qualifiers for \fIstring\fR. | | | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | Returns the fully-qualified name of the parent namespace for namespace \fInamespace\fR. If \fInamespace\fR is not specified, the fully-qualified name of the current namespace's parent is returned. .TP \fBnamespace qualifiers\fR \fIstring\fR Returns any leading namespace qualifiers for \fIstring\fR. Qualifiers are namespace names separated by double colons (\fB::\fR). For the \fIstring\fR \fB::foo::bar::x\fR, this command returns \fB::foo::bar\fR, and for \fB::\fR it returns an empty string. This command is the complement of the \fBnamespace tail\fR command. Note that it does not check whether the namespace names are, in fact, the names of currently defined namespaces. .TP \fBnamespace tail\fR \fIstring\fR Returns the simple name at the end of a qualified string. Qualifiers are namespace names separated by double colons (\fB::\fR). For the \fIstring\fR \fB::foo::bar::x\fR, this command returns \fBx\fR, and for \fB::\fR it returns an empty string. This command is the complement of the \fBnamespace qualifiers\fR command. It does not check whether the namespace names are, in fact, the names of currently defined namespaces. .TP |
| ︙ | ︙ | |||
240 241 242 243 244 245 246 | this command returns an empty string. If the variable has been created but not defined, such as with the \fBvariable\fR command or through a \fBtrace\fR on the variable, this command will return the fully-qualified name of the variable. If no flag is given, \fIname\fR is treated as a command name. See the section \fBNAME RESOLUTION\fR below for an explanation of the rules regarding name resolution. | < | | | | | | | < > | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
this command returns an empty string. If the variable has been
created but not defined, such as with the \fBvariable\fR command
or through a \fBtrace\fR on the variable, this command will return the
fully-qualified name of the variable.
If no flag is given, \fIname\fR is treated as a command name.
See the section \fBNAME RESOLUTION\fR below for an explanation of
the rules regarding name resolution.
.SH "WHAT IS A NAMESPACE?"
.PP
A namespace is a collection of commands and variables.
It encapsulates the commands and variables to ensure that they
won't interfere with the commands and variables of other namespaces.
Tcl has always had one such collection,
which we refer to as the \fIglobal namespace\fR.
The global namespace holds all global variables and commands.
The \fBnamespace eval\fR command lets you create new namespaces.
For example,
.CS
\fBnamespace eval\fR Counter {
\fBnamespace export\fR bump
variable num 0
proc bump {} {
variable num
incr num
}
}
.CE
creates a new namespace containing the variable \fBnum\fR and
the procedure \fBbump\fR.
The commands and variables in this namespace are separate from
other commands and variables in the same program.
If there is a command named \fBbump\fR in the global namespace,
for example, it will be different from the command \fBbump\fR
|
| ︙ | ︙ | |||
282 283 284 285 286 287 288 | Namespaces are dynamic. You can add and delete commands and variables at any time, so you can build up the contents of a namespace over time using a series of \fBnamespace eval\fR commands. For example, the following series of commands has the same effect as the namespace definition shown above: .CS | | | | | | | | | | | | < > < | | | | | | | | | | < | | | < > | | | | | | < > | | | < | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | < > | > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
Namespaces are dynamic.
You can add and delete commands and variables at any time,
so you can build up the contents of a
namespace over time using a series of \fBnamespace eval\fR commands.
For example, the following series of commands has the same effect
as the namespace definition shown above:
.CS
\fBnamespace eval\fR Counter {
variable num 0
proc bump {} {
variable num
return [incr num]
}
}
\fBnamespace eval\fR Counter {
proc test {args} {
return $args
}
}
\fBnamespace eval\fR Counter {
rename test ""
}
.CE
Note that the \fBtest\fR procedure is added to the \fBCounter\fR namespace,
and later removed via the \fBrename\fR command.
.PP
Namespaces can have other namespaces within them,
so they nest hierarchically.
A nested namespace is encapsulated inside its parent namespace
and can not interfere with other namespaces.
.SH "QUALIFIED NAMES"
.PP
Each namespace has a textual name such as
\fBhistory\fR or \fB::safe::interp\fR.
Since namespaces may nest,
qualified names are used to refer to
commands, variables, and child namespaces contained inside namespaces.
Qualified names are similar to the hierarchical path names for
Unix files or Tk widgets,
except that \fB::\fR is used as the separator
instead of \fB/\fR or \fB.\fR.
The topmost or global namespace has the name ``'' (i.e., an empty string),
although \fB::\fR is a synonym.
As an example, the name \fB::safe::interp::create\fR
refers to the command \fBcreate\fR in the namespace \fBinterp\fR
that is a child of namespace \fB::safe\fR,
which in turn is a child of the global namespace, \fB::\fR.
.PP
If you want to access commands and variables from another namespace,
you must use some extra syntax.
Names must be qualified by the namespace that contains them.
From the global namespace,
we might access the \fBCounter\fR procedures like this:
.CS
Counter::bump 5
Counter::Reset
.CE
We could access the current count like this:
.CS
puts "count = $Counter::num"
.CE
When one namespace contains another, you may need more than one
qualifier to reach its elements.
If we had a namespace \fBFoo\fR that contained the namespace \fBCounter\fR,
you could invoke its \fBbump\fR procedure
from the global namespace like this:
.CS
Foo::Counter::bump 3
.CE
.PP
You can also use qualified names when you create and rename commands.
For example, you could add a procedure to the \fBFoo\fR
namespace like this:
.CS
proc Foo::Test {args} {return $args}
.CE
And you could move the same procedure to another namespace like this:
.CS
rename Foo::Test Bar::Test
.CE
.PP
There are a few remaining points about qualified names
that we should cover.
Namespaces have nonempty names except for the global namespace.
\fB::\fR is disallowed in simple command, variable, and namespace names
except as a namespace separator.
Extra colons in any separator part of a qualified name are ignored;
i.e. two or more colons are treated as a namespace separator.
A trailing \fB::\fR in a qualified variable or command name
refers to the variable or command named {}.
However, a trailing \fB::\fR in a qualified namespace name is ignored.
.SH "NAME RESOLUTION"
.PP
In general, all Tcl commands that take variable and command names
support qualified names.
This means you can give qualified names to such commands as
\fBset\fR, \fBproc\fR, \fBrename\fR, and \fBinterp alias\fR.
If you provide a fully-qualified name that starts with a \fB::\fR,
there is no question about what command, variable, or namespace
you mean.
However, if the name does not start with a \fB::\fR
(i.e., is \fIrelative\fR),
Tcl follows a fixed rule for looking it up:
Command and variable names are always resolved
by looking first in the current namespace,
and then in the global namespace.
Namespace names, on the other hand, are always resolved
by looking in only the current namespace.
.PP
In the following example,
.CS
set traceLevel 0
\fBnamespace eval\fR Debug {
printTrace $traceLevel
}
.CE
Tcl looks for \fBtraceLevel\fR in the namespace \fBDebug\fR
and then in the global namespace.
It looks up the command \fBprintTrace\fR in the same way.
If a variable or command name is not found in either context,
the name is undefined.
To make this point absolutely clear, consider the following example:
.CS
set traceLevel 0
\fBnamespace eval\fR Foo {
variable traceLevel 3
\fBnamespace eval\fR Debug {
printTrace $traceLevel
}
}
.CE
Here Tcl looks for \fBtraceLevel\fR first in the namespace \fBFoo::Debug\fR.
Since it is not found there, Tcl then looks for it
in the global namespace.
The variable \fBFoo::traceLevel\fR is completely ignored
during the name resolution process.
.PP
You can use the \fBnamespace which\fR command to clear up any question
about name resolution.
For example, the command:
.CS
\fBnamespace eval\fR Foo::Debug {\fBnamespace which\fR \-variable traceLevel}
.CE
returns \fB::traceLevel\fR.
On the other hand, the command,
.CS
\fBnamespace eval\fR Foo {\fBnamespace which\fR \-variable traceLevel}
.CE
returns \fB::Foo::traceLevel\fR.
.PP
As mentioned above,
namespace names are looked up differently
than the names of variables and commands.
Namespace names are always resolved in the current namespace.
This means, for example,
that a \fBnamespace eval\fR command that creates a new namespace
always creates a child of the current namespace
unless the new namespace name begins with \fB::\fR.
.PP
Tcl has no access control to limit what variables, commands,
or namespaces you can reference.
If you provide a qualified name that resolves to an element
by the name resolution rule above,
you can access the element.
.PP
You can access a namespace variable
from a procedure in the same namespace
by using the \fBvariable\fR command.
Much like the \fBglobal\fR command,
this creates a local link to the namespace variable.
If necessary, it also creates the variable in the current namespace
and initializes it.
Note that the \fBglobal\fR command only creates links
to variables in the global namespace.
It is not necessary to use a \fBvariable\fR command
if you always refer to the namespace variable using an
appropriate qualified name.
.SH "IMPORTING COMMANDS"
.PP
Namespaces are often used to represent libraries.
Some library commands are used so frequently
that it is a nuisance to type their qualified names.
For example, suppose that all of the commands in a package
like BLT are contained in a namespace called \fBBlt\fR.
Then you might access these commands like this:
.CS
Blt::graph .g \-background red
Blt::table . .g 0,0
.CE
If you use the \fBgraph\fR and \fBtable\fR commands frequently,
you may want to access them without the \fBBlt::\fR prefix.
You can do this by importing the commands into the current namespace,
like this:
.CS
\fBnamespace import\fR Blt::*
.CE
This adds all exported commands from the \fBBlt\fR namespace
into the current namespace context, so you can write code like this:
.CS
graph .g \-background red
table . .g 0,0
.CE
The \fBnamespace import\fR command only imports commands
from a namespace that that namespace exported
with a \fBnamespace export\fR command.
.PP
Importing \fIevery\fR command from a namespace is generally
a bad idea since you don't know what you will get.
It is better to import just the specific commands you need.
For example, the command
.CS
\fBnamespace import\fR Blt::graph Blt::table
.CE
imports only the \fBgraph\fR and \fBtable\fR commands into the
current context.
.PP
If you try to import a command that already exists, you will get an
error. This prevents you from importing the same command from two
different packages. But from time to time (perhaps when debugging),
you may want to get around this restriction. You may want to
reissue the \fBnamespace import\fR command to pick up new commands
that have appeared in a namespace. In that case, you can use the
\fB\-force\fR option, and existing commands will be silently overwritten:
.CS
\fBnamespace import\fR \-force Blt::graph Blt::table
.CE
If for some reason, you want to stop using the imported commands,
you can remove them with a \fBnamespace forget\fR command, like this:
.CS
\fBnamespace forget\fR Blt::*
.CE
This searches the current namespace for any commands imported from \fBBlt\fR.
If it finds any, it removes them. Otherwise, it does nothing.
After this, the \fBBlt\fR commands must be accessed with the \fBBlt::\fR
prefix.
.PP
When you delete a command from the exporting namespace like this:
.CS
rename Blt::graph ""
.CE
the command is automatically removed from all namespaces that import it.
.SH "EXPORTING COMMANDS"
You can export commands from a namespace like this:
.CS
\fBnamespace eval\fR Counter {
\fBnamespace export\fR bump reset
variable Num 0
variable Max 100
proc bump {{by 1}} {
variable Num
incr Num $by
Check
return $Num
}
proc reset {} {
variable Num
set Num 0
}
proc Check {} {
variable Num
variable Max
if {$Num > $Max} {
error "too high!"
}
}
}
.CE
The procedures \fBbump\fR and \fBreset\fR are exported,
so they are included when you import from the \fBCounter\fR namespace,
like this:
.CS
\fBnamespace import\fR Counter::*
.CE
However, the \fBCheck\fR procedure is not exported,
so it is ignored by the import operation.
.PP
The \fBnamespace import\fR command only imports commands
that were declared as exported by their namespace.
The \fBnamespace export\fR command specifies what commands
may be imported by other namespaces.
If a \fBnamespace import\fR command specifies a command
that is not exported, the command is not imported.
.SH "SCOPED SCRIPTS"
The \fBnamespace code\fR command is the means by which a script may be
packaged for evaluation in a namespace other than the one in which it
was created. It is used most often to create event handlers, Tk bindings,
and traces for evaluation in the global context. For instance, the following
code indicates how to direct a variable trace callback into the current
namespace:
.CS
\fBnamespace eval\fR a {
variable b
proc theTraceCallback { n1 n2 op } {
upvar 1 $n1 var
puts "the value of $n1 has changed to $var"
return
}
trace variable b w [\fBnamespace code\fR theTraceCallback]
}
set a::b c
.CE
When executed, it prints the message:
.CS
the value of a::b has changed to c
.CE
.SH EXAMPLES
Create a namespace containing a variable and an exported command:
.CS
\fBnamespace eval\fR foo {
variable bar 0
proc grill {} {
variable bar
puts "called [incr bar] times"
}
\fBnamespace export\fR grill
}
.CE
.PP
Call the command defined in the previous example in various ways.
.CS
# Direct call
foo::grill
# Import into current namespace, then call local alias
namespace import foo::grill
grill
.CE
.PP
Look up where the command imported in the previous example came from:
.CS
puts "grill came from [\fBnamespace origin\fR grill]"
.CE
.SH "SEE ALSO"
variable(n)
.SH KEYWORDS
exported, internal, variable
|
Changes to doc/open.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: open.n,v 1.16.2.4 2006/03/16 21:11:57 andreas_kupries Exp $ '\" .so man.macros .TH open n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME open \- Open a file-based or command pipeline channel |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | \fBw+\fR Open the file for reading and writing. Truncate it if it exists. If it doesn't exist, create a new file. .TP 15 \fBa\fR Open the file for writing only. If the file doesn't exist, create a new empty file. | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | \fBw+\fR Open the file for reading and writing. Truncate it if it exists. If it doesn't exist, create a new file. .TP 15 \fBa\fR Open the file for writing only. If the file doesn't exist, create a new empty file. Set the file pointer to the end of the file prior to each write. .TP 15 \fBa+\fR Open the file for reading and writing. If the file doesn't exist, create a new empty file. Set the initial access position to the end of the file. .PP In the second form, \fIaccess\fR consists of a list of any of the |
| ︙ | ︙ | |||
128 129 130 131 132 133 134 | standard output for the pipeline is directed to the current standard output unless overridden by the command. If read-only access is used (e.g. \fIaccess\fR is \fBr\fR), standard input for the pipeline is taken from the current standard input unless overridden by the command. The id of the spawned process is accessible through the \fBpid\fR command, using the channel id returned by \fBopen\fR as argument. | | > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | < | < < > > > > > > > > > > > > > | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 |
standard output for the pipeline is directed to the current standard
output unless overridden by the command.
If read-only access is used (e.g. \fIaccess\fR is \fBr\fR),
standard input for the pipeline is taken from the current standard
input unless overridden by the command.
The id of the spawned process is accessible through the \fBpid\fR
command, using the channel id returned by \fBopen\fR as argument.
.PP
If the command (or one of the commands) executed in the command
pipeline returns an error (according to the definition in \fBexec\fR),
a Tcl error is generated when \fBclose\fR is called on the channel
unless the pipeline is in non-blocking mode then no exit status is
returned (a silent \fBclose\fR with -blocking 0).
.PP
It is often useful to use the \fBfileevent\fR command with pipelines
so other processing may happen at the same time as running the command
in the background.
.VS 8.4
.SH "SERIAL COMMUNICATIONS"
.PP
If \fIfileName\fR refers to a serial port, then the specified serial port
is opened and initialized in a platform-dependent manner. Acceptable
values for the \fIfileName\fR to use to open a serial port are described in
the PORTABILITY ISSUES section.
.PP
The \fBfconfigure\fR command can be used to query and set additional
configuration options specific to serial ports (where supported):
.TP
\fB\-mode\fR \fIbaud\fB,\fIparity\fB,\fIdata\fB,\fIstop\fR
This option is a set of 4 comma-separated values: the baud rate, parity,
number of data bits, and number of stop bits for this serial port. The
\fIbaud\fR rate is a simple integer that specifies the connection speed.
\fIParity\fR is one of the following letters: \fBn\fR, \fBo\fR, \fBe\fR,
\fBm\fR, \fBs\fR; respectively signifying the parity options of ``none'',
``odd'', ``even'', ``mark'', or ``space''. \fIData\fR is the number of
data bits and should be an integer from 5 to 8, while \fIstop\fR is the
number of stop bits and should be the integer 1 or 2.
.TP
\fB\-handshake\fR \fItype\fR
(Windows and Unix). This option is used to setup automatic handshake
control. Note that not all handshake types maybe supported by your operating
system. The \fItype\fR parameter is case-independent.
.sp
If \fItype\fR is \fBnone\fR then any handshake is switched off.
\fBrtscts\fR activates hardware handshake. Hardware handshake signals
are described below.
For software handshake \fBxonxoff\fR the handshake characters can be redefined
with \fB-xchar\fR.
An additional hardware handshake \fBdtrdsr\fR is available only under Windows.
There is no default handshake configuration, the initial value depends
on your operating system settings.
The \fB-handshake\fR option cannot be queried.
.TP
\fB\-queue\fR
(Windows and Unix). The \fB-queue\fR option can only be queried.
It returns a list of two integers representing the current number
of bytes in the input and output queue respectively.
.TP
\fB\-timeout\fR \fImsec\fR
(Windows and Unix). This option is used to set the timeout for blocking
read operations. It specifies the maximum interval between the
reception of two bytes in milliseconds.
For Unix systems the granularity is 100 milliseconds.
The \fB-timeout\fR option does not affect write operations or
nonblocking reads.
This option cannot be queried.
.TP
\fB\-ttycontrol\fR \fI{signal boolean signal boolean ...}\fR
(Windows and Unix). This option is used to setup the handshake
output lines (see below) permanently or to send a BREAK over the serial line.
The \fIsignal\fR names are case-independent.
\fB{RTS 1 DTR 0}\fR sets the RTS output to high and the DTR output to low.
The BREAK condition (see below) is enabled and disabled with \fB{BREAK 1}\fR and
\fB{BREAK 0}\fR respectively.
It's not a good idea to change the \fBRTS\fR (or \fBDTR\fR) signal
with active hardware handshake \fBrtscts\fR (or \fBdtrdsr\fR).
The result is unpredictable.
The \fB-ttycontrol\fR option cannot be queried.
.TP
\fB\-ttystatus\fR
(Windows and Unix). The \fB-ttystatus\fR option can only be
queried. It returns the current modem status and handshake input signals
(see below).
The result is a list of signal,value pairs with a fixed order,
e.g. \fB{CTS 1 DSR 0 RING 1 DCD 0}\fR.
The \fIsignal\fR names are returned upper case.
.TP
\fB\-xchar\fR \fI{xonChar xoffChar}\fR
(Windows and Unix). This option is used to query or change the software
handshake characters. Normally the operating system default should be
DC1 (0x11) and DC3 (0x13) representing the ASCII standard
XON and XOFF characters.
.TP
\fB\-pollinterval\fR \fImsec\fR
(Windows only). This option is used to set the maximum time between
polling for fileevents.
This affects the time interval between checking for events throughout the Tcl
interpreter (the smallest value always wins). Use this option only if
you want to poll the serial port more or less often than 10 msec
(the default).
.TP
\fB\-sysbuffer\fR \fIinSize\fR
.TP
\fB\-sysbuffer\fR \fI{inSize outSize}\fR
(Windows only). This option is used to change the size of Windows
system buffers for a serial channel. Especially at higher communication
rates the default input buffer size of 4096 bytes can overrun
for latent systems. The first form specifies the input buffer size,
in the second form both input and output buffers are defined.
.TP
\fB\-lasterror\fR
(Windows only). This option is query only.
In case of a serial communication error, \fBread\fR or \fBputs\fR
returns a general Tcl file I/O error.
\fBfconfigure -lasterror\fR can be called to get a list of error details.
See below for an explanation of the various error codes.
.SH "SERIAL PORT SIGNALS"
.PP
RS-232 is the most commonly used standard electrical interface for serial
communications. A negative voltage (-3V..-12V) define a mark (on=1) bit and
a positive voltage (+3..+12V) define a space (off=0) bit (RS-232C). The
following signals are specified for incoming and outgoing data, status
lines and handshaking. Here we are using the terms \fIworkstation\fR for
your computer and \fImodem\fR for the external device, because some signal
names (DCD, RI) come from modems. Of course your external device may use
these signal lines for other purposes.
.IP \fBTXD(output)\fR
\fBTransmitted Data:\fR Outgoing serial data.
.IP \fBRXD(input)\fR
\fBReceived Data:\fRIncoming serial data.
.IP \fBRTS(output)\fR
\fBRequest To Send:\fR This hardware handshake line informs the modem that
your workstation is ready to receive data. Your workstation may
automatically reset this signal to indicate that the input buffer is full.
.IP \fBCTS(input)\fR
\fBClear To Send:\fR The complement to RTS. Indicates that the modem is
ready to receive data.
.IP \fBDTR(output)\fR
\fBData Terminal Ready:\fR This signal tells the modem that the workstation
is ready to establish a link. DTR is often enabled automatically whenever a
serial port is opened.
.IP \fBDSR(input)\fR
\fBData Set Ready:\fR The complement to DTR. Tells the workstation that the
modem is ready to establish a link.
.IP \fBDCD(input)\fR
\fBData Carrier Detect:\fR This line becomes active when a modem detects
a "Carrier" signal.
.IP \fBRI(input)\fR
\fBRing Indicator:\fR Goes active when the modem detects an incoming call.
.IP \fBBREAK\fR
A BREAK condition is not a hardware signal line, but a logical zero on the
TXD or RXD lines for a long period of time, usually 250 to 500
milliseconds. Normally a receive or transmit data signal stays at the mark
(on=1) voltage until the next character is transferred. A BREAK is sometimes
used to reset the communications line or change the operating mode of
communications hardware.
.SH "ERROR CODES (Windows only)"
.PP
A lot of different errors may occur during serial read operations or during
event polling in background. The external device may have been switched
off, the data lines may be noisy, system buffers may overrun or your mode
settings may be wrong. That's why a reliable software should always
\fBcatch\fR serial read operations. In cases of an error Tcl returns a
general file I/O error. Then \fBfconfigure -lasterror\fR may help to
locate the problem. The following error codes may be returned.
.TP 10
\fBRXOVER\fR
Windows input buffer overrun. The data comes faster than your scripts reads
it or your system is overloaded. Use \fBfconfigure -sysbuffer\fR to avoid a
temporary bottleneck and/or make your script faster.
.TP 10
\fBTXFULL\fR
Windows output buffer overrun. Complement to RXOVER. This error should
practically not happen, because Tcl cares about the output buffer status.
.TP 10
\fBOVERRUN\fR
UART buffer overrun (hardware) with data lost.
The data comes faster than the system driver receives it.
Check your advanced serial port settings to enable the FIFO (16550) buffer
and/or setup a lower(1) interrupt threshold value.
.TP 10
\fBRXPARITY\fR
A parity error has been detected by your UART.
Wrong parity settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
may cause this error.
.TP 10
\fBFRAME\fR
A stop-bit error has been detected by your UART.
Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
may cause this error.
.TP 10
\fBBREAK\fR
A BREAK condition has been detected by your UART (see above).
.VE
.SH "PORTABILITY ISSUES"
.TP
\fBWindows \fR(all versions)
Valid values for \fIfileName\fR to open a serial port are of the form
\fBcom\fIX\fB:\fR, where \fIX\fR is a number, generally from 1 to 4.
This notation only works for serial ports from 1 to 9, if the system
happens to have more than four. An attempt to open a serial port that
does not exist or has a number greater than 9 will fail. An alternate
form of opening serial ports is to use the filename \fB\e\e.\ecomX\fR,
where X is any number that corresponds to a serial port; please note
that this method is considerably slower on Windows 95 and Windows 98.
.TP
\fBWindows NT\fR
When running Tcl interactively, there may be some strange interactions
between the real console, if one is present, and a command pipeline that uses
standard input or output. If a command pipeline is opened for reading, some
of the lines entered at the console will be sent to the command pipeline and
some will be sent to the Tcl evaluator. If a command pipeline is opened for
writing, keystrokes entered into the console are not visible until the
pipe is closed. This behavior occurs whether the command pipeline is
executing 16-bit or 32-bit applications. These problems only occur because
both Tcl and the child application are competing for the console at
the same time. If the command pipeline is started from a script, so that Tcl
is not accessing the console, or if the command pipeline does not use
standard input or output, but is redirected from or to a file, then the
above problems do not occur.
.TP
\fBWindows 95\fR
A command pipeline that executes a 16-bit DOS application cannot be opened
for both reading and writing, since 16-bit DOS applications that receive
standard input from a pipe and send standard output to a pipe run
synchronously. Command pipelines that do not execute 16-bit DOS
applications run asynchronously and can be opened for both reading and
writing.
.sp
When running Tcl interactively, there may be some strange interactions
between the real console, if one is present, and a command pipeline that uses
standard input or output. If a command pipeline is opened for reading from
a 32-bit application, some of the keystrokes entered at the console will be
sent to the command pipeline and some will be sent to the Tcl evaluator. If
a command pipeline is opened for writing to a 32-bit application, no output
is visible on the console until the pipe is closed. These problems only
occur because both Tcl and the child application are competing for the
console at the same time. If the command pipeline is started from a script,
so that Tcl is not accessing the console, or if the command pipeline does
not use standard input or output, but is redirected from or to a file, then
the above problems do not occur.
.sp
Whether or not Tcl is running interactively, if a command pipeline is opened
for reading from a 16-bit DOS application, the call to \fBopen\fR will not
return until end-of-file has been received from the command pipeline's
standard output. If a command pipeline is opened for writing to a 16-bit DOS
application, no data will be sent to the command pipeline's standard output
until the pipe is actually closed. This problem occurs because 16-bit DOS
applications are run synchronously, as described above.
.TP
\fBMacintosh\fR
Opening a serial port is not currently implemented under Macintosh.
.sp
Opening a command pipeline is not supported under Macintosh, since
applications do not support the concept of standard input or output.
.TP
\fBUnix\fR\0\0\0\0\0\0\0
Valid values for \fIfileName\fR to open a serial port are generally of the
form \fB/dev/tty\fIX\fR, where \fIX\fR is \fBa\fR or \fBb\fR, but the name
of any pseudo-file that maps to a serial port may be used.
.VS 8.4
Advanced configuration options are only supported for serial ports
when Tcl is built to use the POSIX serial interface.
.VE 8.4
.sp
When running Tcl interactively, there may be some strange interactions
between the console, if one is present, and a command pipeline that uses
standard input. If a command pipeline is opened for reading, some
of the lines entered at the console will be sent to the command pipeline and
some will be sent to the Tcl evaluator. This problem only occurs because
both Tcl and the child application are competing for the console at the
same time. If the command pipeline is started from a script, so that Tcl is
not accessing the console, or if the command pipeline does not use standard
input, but is redirected from a file, then the above problem does not occur.
.LP
See the PORTABILITY ISSUES section of the \fBexec\fR command for additional
information not specific to command pipelines about executing
applications on the various platforms
.SH "EXAMPLE"
Open a command pipeline and catch any errors:
.CS
set fl [\fBopen\fR "| ls this_file_does_not_exist"]
set data [read $fl]
if {[catch {close $fl} err]} {
puts "ls command failed: $err"
}
.CE
.SH "SEE ALSO"
file(n), close(n), filename(n), fconfigure(n), gets(n), read(n),
puts(n), exec(n), pid(n), fopen(3)
.SH KEYWORDS
access mode, append, create, file, non-blocking, open, permissions,
pipeline, process, serial
|
Changes to doc/package.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: package.n,v 1.6.2.3 2006/09/04 19:35:49 hobbs Exp $ '\" .so man.macros .TH package n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME package \- Facilities for package loading and version control |
| ︙ | ︙ | |||
86 87 88 89 90 91 92 | It is typically invoked once as part of an \fBifneeded\fR script, and again by the package itself when it is finally loaded. An error occurs if a different version of \fIpackage\fR has been provided by a previous \fBpackage provide\fR command. If the \fIversion\fR argument is omitted, then the command returns the version number that is currently provided, or an empty string if no \fBpackage provide\fR command has been | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | It is typically invoked once as part of an \fBifneeded\fR script, and again by the package itself when it is finally loaded. An error occurs if a different version of \fIpackage\fR has been provided by a previous \fBpackage provide\fR command. If the \fIversion\fR argument is omitted, then the command returns the version number that is currently provided, or an empty string if no \fBpackage provide\fR command has been invoked for \fIpackage\fR in this interpreter. .TP \fBpackage require \fR?\fB\-exact\fR? \fIpackage \fR?\fIversion\fR? This command is typically invoked by Tcl code that wishes to use a particular version of a particular package. The arguments indicate which package is wanted, and the command ensures that a suitable version of the package is loaded into the interpreter. If the command succeeds, it returns the version number that is |
| ︙ | ︙ | |||
157 158 159 160 161 162 163 | commands. .TP \fBpackage vsatisfies \fIversion1 version2\fR Returns 1 if scripts written for \fIversion2\fR will work unchanged with \fIversion1\fR (i.e. \fIversion1\fR is equal to or greater than \fIversion2\fR and they both have the same major version number), 0 otherwise. | < < > > > > > > > > > > > > > > > > > > > | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
commands.
.TP
\fBpackage vsatisfies \fIversion1 version2\fR
Returns 1 if scripts written for \fIversion2\fR will work unchanged
with \fIversion1\fR (i.e. \fIversion1\fR is equal to or greater
than \fIversion2\fR and they both have the same major version
number), 0 otherwise.
.SH "VERSION NUMBERS"
.PP
Version numbers consist of one or more decimal numbers separated
by dots, such as 2 or 1.162 or 3.1.13.1.
The first number is called the major version number.
Larger numbers correspond to later versions of a package, with
leftmost numbers having greater significance.
For example, version 2.1 is later than 1.3 and version
3.4.6 is later than 3.3.5.
Missing fields are equivalent to zeroes: version 1.3 is the
same as version 1.3.0 and 1.3.0.0, so it is earlier than 1.3.1 or 1.3.0.2.
A later version number is assumed to be upwards compatible with
an earlier version number as long as both versions have the same
major version number.
For example, Tcl scripts written for version 2.3 of a package should
work unchanged under versions 2.3.2, 2.4, and 2.5.1.
Changes in the major version number signify incompatible changes:
if code is written to use version 2.1 of a package, it is not guaranteed
to work unmodified with either version 1.7.3 or version 3.1.
.SH "PACKAGE INDICES"
.PP
The recommended way to use packages in Tcl is to invoke \fBpackage require\fR
and \fBpackage provide\fR commands in scripts, and use the procedure
\fBpkg_mkIndex\fR to create package index files.
Once you've done this, packages will be loaded automatically
in response to \fBpackage require\fR commands.
See the documentation for \fBpkg_mkIndex\fR for details.
.SH EXAMPLES
To state that a Tcl script requires the Tk and http packages, put this
at the top of the script:
.CS
\fBpackage require\fR Tk
\fBpackage require\fR http
.CE
.PP
To test to see if the Snack package is available and load if it is
(often useful for optional enhancements to programs where the loss of
the functionality is not critical) do this:
.CS
if {[catch {\fBpackage require\fR Snack}]} {
# Error thrown - package not found.
# Set up a dummy interface to work around the absence
} else {
# We have the package, configure the app to use it
}
.CE
.SH "SEE ALSO"
msgcat(n), packagens(n), pkgMkIndex(n)
.SH KEYWORDS
package, version
|
Changes to doc/pid.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: pid.n,v 1.3.18.1 2004/10/27 14:23:57 dkf Exp $ '\" .so man.macros .TH pid n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pid \- Retrieve process identifiers .SH SYNOPSIS \fBpid \fR?\fIfileId\fR? .BE .SH DESCRIPTION .PP If the \fIfileId\fR argument is given then it should normally refer to a process pipeline created with the \fBopen\fR command. In this case the \fBpid\fR command will return a list whose elements are the process identifiers of all the processes in the pipeline, in order. The list will be empty if \fIfileId\fR refers to an open file that isn't a process pipeline. If no \fIfileId\fR argument is given then \fBpid\fR returns the process identifier of the current process. All process identifiers are returned as decimal strings. .SH EXAMPLE Print process information about the processes in a pipeline using the SysV \fBps\fR program before reading the output of that pipeline: .PP .CS set pipeline [open "| zcat somefile.gz | grep foobar | sort -u"] # Print process information exec ps -fp [\fBpid\fR $pipeline] >@stdout # Print a separator and then the output of the pipeline puts [string repeat - 70] puts [read $pipeline] close $pipeline .CE .SH "SEE ALSO" exec(n), open(n) .SH KEYWORDS file, pipeline, process identifier |
Changes to doc/proc.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: proc.n,v 1.3.18.1 2004/10/27 14:23:57 dkf Exp $ '\" .so man.macros .TH proc n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME proc \- Create a Tcl procedure |
| ︙ | ︙ | |||
65 66 67 68 69 70 71 72 73 74 75 76 77 | The \fBproc\fR command returns an empty string. When a procedure is invoked, the procedure's return value is the value specified in a \fBreturn\fR command. If the procedure doesn't execute an explicit \fBreturn\fR, then its return value is the value of the last command executed in the procedure's body. If an error occurs while executing the procedure body, then the procedure-as-a-whole will return that same error. .SH "SEE ALSO" info(n), unknown(n) .SH KEYWORDS argument, procedure | > > > > > > > > > > > > > > > > > > > > | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
The \fBproc\fR command returns an empty string. When a procedure is
invoked, the procedure's return value is the value specified in a
\fBreturn\fR command. If the procedure doesn't execute an explicit
\fBreturn\fR, then its return value is the value of the last command
executed in the procedure's body.
If an error occurs while executing the procedure
body, then the procedure-as-a-whole will return that same error.
.SH EXAMPLES
This is a procedure that accepts arbitrarily many arguments and prints
them out, one by one.
.CS
\fBproc\fR printArguments args {
foreach arg $args {
puts $arg
}
}
.CE
.PP
This procedure is a bit like the \fBincr\fR command, except it
multiplies the contents of the named variable by the value, which
defaults to \fB2\fR:
.CS
\fBproc\fR mult {varName {multiplier 2}} {
upvar 1 $varName var
set var [expr {$var * $multiplier}]
}
.CE
.SH "SEE ALSO"
info(n), unknown(n)
.SH KEYWORDS
argument, procedure
|
Changes to doc/puts.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: puts.n,v 1.5.8.1 2004/10/27 14:23:57 dkf Exp $ '\" .so man.macros .TH puts n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME puts \- Write to a channel |
| ︙ | ︙ | |||
64 65 66 67 68 69 70 71 72 73 74 75 76 | It is possible for an arbitrarily large amount of data to be buffered for a channel in nonblocking mode, which could consume a large amount of memory. To avoid wasting memory, nonblocking I/O should normally be used in an event-driven fashion with the \fBfileevent\fR command (don't invoke \fBputs\fR unless you have recently been notified via a file event that the channel is ready for more output data). .SH "SEE ALSO" file(n), fileevent(n), Tcl_StandardChannels(3) .SH KEYWORDS channel, newline, output, write | > > > > > > > > > > > > > > > > > > > > > > > > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | It is possible for an arbitrarily large amount of data to be buffered for a channel in nonblocking mode, which could consume a large amount of memory. To avoid wasting memory, nonblocking I/O should normally be used in an event-driven fashion with the \fBfileevent\fR command (don't invoke \fBputs\fR unless you have recently been notified via a file event that the channel is ready for more output data). .SH EXAMPLES Write a short message to the console (or wherever \fBstdout\fR is directed): .CS \fBputs\fR "Hello, World!" .CE .PP Print a message in several parts: .CS \fBputs\fR -nonewline "Hello, " \fBputs\fR "World!" .CE .PP Print a message to the standard error channel: .CS \fBputs\fR stderr "Hello, World!" .CE .PP Append a log message to a file: .CS set chan [open my.log a] set timestamp [clock format [clock seconds]] \fBputs\fR $chan "$timestamp - Hello, World!" close $chan .CE .SH "SEE ALSO" file(n), fileevent(n), Tcl_StandardChannels(3) .SH KEYWORDS channel, newline, output, write |
Changes to doc/pwd.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: pwd.n,v 1.3.18.1 2004/10/27 14:23:57 dkf Exp $ '\" .so man.macros .TH pwd n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pwd \- Return the absolute path of the current working directory .SH SYNOPSIS \fBpwd\fR .BE .SH DESCRIPTION .PP Returns the absolute path name of the current working directory. .SH EXAMPLE Sometimes it is useful to change to a known directory when running some external command using \fBexec\fR, but it is important to keep the application usually running in the directory that it was started in (unless the user specifies otherwise) since that minimises user confusion. The way to do this is to save the current directory while the external command is being run: .CS set tarFile [file normalize somefile.tar] set savedDir [\fBpwd\fR] cd /tmp exec tar -xf $tarFile cd $savedDir .CE .SH "SEE ALSO" file(n), cd(n), glob(n), filename(n) .SH KEYWORDS working directory |
Changes to doc/re_syntax.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" Copyright (c) 1999 Scriptics Corporation '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: re_syntax.n,v 1.3.32.1 2006/04/12 02:19:53 das Exp $ '\" .so man.macros .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands" .BS .SH NAME re_syntax \- Syntax of Tcl regular expressions. .BE |
| ︙ | ︙ | |||
275 276 277 278 279 280 281 | (not all collating elements!) belonging to that class. Standard character classes are: .PP .RS .ne 5 | < > | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 | (not all collating elements!) belonging to that class. Standard character classes are: .PP .RS .ne 5 .ta 3c .nf \fBalpha\fR A letter. \fBupper\fR An upper-case letter. \fBlower\fR A lower-case letter. \fBdigit\fR A decimal digit. \fBxdigit\fR A hexadecimal digit. \fBalnum\fR An alphanumeric (letter or digit). \fBprint\fR An alphanumeric (same as alnum). |
| ︙ | ︙ |
Changes to doc/read.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: read.n,v 1.7.8.1 2004/10/27 14:23:57 dkf Exp $ '\" .so man.macros .TH read n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME read \- Read from a channel |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | from the serial port. .TP \fBread \fIchannelId\fR In this form \fBread\fR blocks until the reception of the end-of-file character, see \fBfconfigure -eofchar\fR. If there no end-of-file character has been configured for the channel, then \fBread\fR will block forever. | | > > > > > > > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | from the serial port. .TP \fBread \fIchannelId\fR In this form \fBread\fR blocks until the reception of the end-of-file character, see \fBfconfigure -eofchar\fR. If there no end-of-file character has been configured for the channel, then \fBread\fR will block forever. .SH "EXAMPLE" This example code reads a file all at once, and splits it into a list, with each line in the file corresponding to an element in the list: .CS set fl [open /proc/meminfo] set data [\fBread\fR $fl] close $fl set lines [split $data \\n] .CE .SH "SEE ALSO" file(n), eof(n), fblocked(n), fconfigure(n), Tcl_StandardChannels(3) .SH KEYWORDS blocking, channel, end of line, end of file, nonblocking, read, translation, encoding |
Changes to doc/regexp.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: regexp.n,v 1.12.2.1 2004/10/27 14:23:57 dkf Exp $ '\" .so man.macros .TH regexp n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regexp \- Match a regular expression against a string |
| ︙ | ︙ | |||
122 123 124 125 126 127 128 129 130 131 132 133 134 | .PP If there are more \fIsubMatchVar\fR's than parenthesized subexpressions within \fIexp\fR, or if a particular subexpression in \fIexp\fR doesn't match the string (e.g. because it was in a portion of the expression that wasn't matched), then the corresponding \fIsubMatchVar\fR will be set to ``\fB\-1 \-1\fR'' if \fB\-indices\fR has been specified or to an empty string otherwise. .SH "SEE ALSO" re_syntax(n), regsub(n) .SH KEYWORDS match, regular expression, string | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
.PP
If there are more \fIsubMatchVar\fR's than parenthesized
subexpressions within \fIexp\fR, or if a particular subexpression
in \fIexp\fR doesn't match the string (e.g. because it was in a
portion of the expression that wasn't matched), then the corresponding
\fIsubMatchVar\fR will be set to ``\fB\-1 \-1\fR'' if \fB\-indices\fR
has been specified or to an empty string otherwise.
.SH EXAMPLES
Find the first occurrence of a word starting with \fBfoo\fR in a
string that is not actually an instance of \fBfoobar\fR, and get the
letters following it up to the end of the word into a variable:
.CS
\fBregexp\fR {\\<foo(?!bar\\>)(\\w*)} $string \-> restOfWord
.CE
Note that the whole matched substring has been placed in the variable
\fB\->\fR which is a name chosen to look nice given that we are not
actually interested in its contents.
.PP
Find the index of the word \fBbadger\fR (in any case) within a string
and store that in the variable \fBlocation\fR:
.CS
\fBregexp\fR \-indices {(?i)\\<badger\\>} $string location
.CE
.PP
Count the number of octal digits in a string:
.CS
\fBregexp\fR \-all {[0\-7]} $string
.CE
.PP
List all words (consisting of all sequences of non-whitespace
characters) in a string:
.CS
\fBregexp\fR \-all \-inline {\\S+} $string
.CE
.SH "SEE ALSO"
re_syntax(n), regsub(n)
.SH KEYWORDS
match, regular expression, string
|
Changes to doc/registry.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2002 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" Copyright (c) 2002 ActiveState Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: registry.n,v 1.8.2.2 2004/11/12 09:02:30 das Exp $ '\" .so man.macros .TH registry n 1.1 registry "Tcl Bundled Packages" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME registry \- Manipulate the Windows registry |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | \fBHKEY_DYN_DATA\fR. The \fIkeypath\fR can be one or more .VE registry key names separated by backslash (\fB\e\fR) characters. .PP \fIOption\fR indicates what to do with the registry key name. Any unique abbreviation for \fIoption\fR is acceptable. The valid options are: | < > | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
\fBHKEY_DYN_DATA\fR. The \fIkeypath\fR can be one or more
.VE
registry key names separated by backslash (\fB\e\fR) characters.
.PP
\fIOption\fR indicates what to do with the registry key name. Any
unique abbreviation for \fIoption\fR is acceptable. The valid options
are:
.VS 8.4
.TP
\fBregistry broadcast \fIkeyName\fR ?\fI-timeout milliseconds\fR?
.
Sends a broadcast message to the system and running programs to notify them
of certain updates. This is necessary to propagate changes to key registry
keys like Environment. The timeout specifies the amount of time, in
milliseconds, to wait for applications to respond to the broadcast message.
It defaults to 3000. The following example demonstrates how to add a path
to the global Environment and notify applications of the change without
requiring a logoff/logon step (assumes admin privileges):
.CS
set regPath {HKEY_LOCAL_MACHINE\\SYSTEM\\CurrentControlSet\\Control\\Session Manager\\Environment}
set curPath [registry get $regPath "Path"]
registry set $regPath "Path" "$curPath;$addPath"
registry broadcast "Environment"
.CE
.VE 8.4
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 | The registry value contains a device-driver resource list. The data is represented exactly in Tcl, including any embedded nulls. .PP In addition to the symbolically named types listed above, unknown types are identified using a 32-bit integer that corresponds to the type code returned by the system interfaces. In this case, the data is represented exactly in Tcl, including any embedded nulls. | < > > > > > > > > > > > > > > > > | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
The registry value contains a device-driver resource list. The data
is represented exactly in Tcl, including any embedded nulls.
.PP
In addition to the symbolically named types listed above, unknown
types are identified using a 32-bit integer that corresponds to the
type code returned by the system interfaces. In this case, the data
is represented exactly in Tcl, including any embedded nulls.
.SH "PORTABILITY ISSUES"
The registry command is only available on Windows.
.SH EXAMPLE
Print out how double-clicking on a Tcl script file will invoke a Tcl
interpreter:
.CS
package require registry
set ext .tcl
# Read the type name
set type [\fBregistry get\fR HKEY_CLASSES_ROOT\e\e$ext {}]
# Work out where to look for the command
set path HKEY_CLASSES_ROOT\e\e$type\e\eShell\e\eOpen\e\ecommand
# Read the command!
set command [\fBregistry get\fR $path {}]
puts "$ext opens with $command"
.CE
.SH KEYWORDS
registry
|
Changes to doc/regsub.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: regsub.n,v 1.9.2.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH regsub n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME regsub \- Perform substitutions based on regular expression pattern matching |
| ︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 | .VS 8.4 If \fIvarName\fR is supplied, the command returns a count of the number of matching ranges that were found and replaced, otherwise the string after replacement is returned. .VE 8.4 See the manual entry for \fBregexp\fR for details on the interpretation of regular expressions. .SH "SEE ALSO" | > > > > > > > > > > > > > > > > > > > > > > > > > > | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
.VS 8.4
If \fIvarName\fR is supplied, the command returns a count of the
number of matching ranges that were found and replaced, otherwise the
string after replacement is returned.
.VE 8.4
See the manual entry for \fBregexp\fR for details on the interpretation
of regular expressions.
.SH EXAMPLES
Replace (in the string in variable \fIstring\fR) every instance of
\fBfoo\fR which is a word by itself with \fBbar\fR:
.CS
\fBregsub\fR -all {\e<foo\e>} $string bar string
.CE
.PP
Insert double-quotes around the first instance of the word
\fBinteresting\fR, however it is capitalised.
.CS
\fBregsub\fR -nocase {\e<interesting\e>} $string {"&"} string
.CE
.PP
Convert all non-ASCII and Tcl-significant characters into \eu escape
sequences by using \fBregsub\fR and \fBsubst\fR in combination:
.CS
# This RE is just a character class for everything "bad"
set RE {[][{}\e$\es\eu0100-\euffff]}
# We will substitute with a fragment of Tcl script in brackets
set substitution {[format \e\e\e\eu%04x [scan "\e\e&" %c]]}
# Now we apply the substitution to get a subst-string that
# will perform the computational parts of the conversion.
set quoted [subst [\fBregsub\fR -all $RE $string $substitution]]
.CE
.SH "SEE ALSO"
regexp(n), re_syntax(n), subst(n)
.SH KEYWORDS
match, pattern, regular expression, substitute
|
Changes to doc/rename.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: rename.n,v 1.3.18.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH rename n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME rename \- Rename or delete a command |
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 | is now called \fInewName\fR. If \fInewName\fR is an empty string then \fIoldName\fR is deleted. \fIoldName\fR and \fInewName\fR may include namespace qualifiers (names of containing namespaces). If a command is renamed into a different namespace, future invocations of it will execute in the new namespace. The \fBrename\fR command returns an empty string as result. .SH "SEE ALSO" namespace(n), proc(n) .SH KEYWORDS command, delete, namespace, rename | > > > > > > > > > > > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
is now called \fInewName\fR.
If \fInewName\fR is an empty string then \fIoldName\fR is deleted.
\fIoldName\fR and \fInewName\fR may include namespace qualifiers
(names of containing namespaces).
If a command is renamed into a different namespace,
future invocations of it will execute in the new namespace.
The \fBrename\fR command returns an empty string as result.
.SH EXAMPLE
The \fBrename\fR command can be used to wrap the standard Tcl commands
with your own monitoring machinery. For example, you might wish to
count how often the \fBsource\fR command is called:
.CS
\fBrename\fR ::source ::theRealSource
set sourceCount 0
proc ::source args {
global sourceCount
puts "called source for the [incr sourceCount]'th time"
uplevel 1 ::theRealSource $args
}
.CE
.SH "SEE ALSO"
namespace(n), proc(n)
.SH KEYWORDS
command, delete, namespace, rename
|
Changes to doc/return.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | < | > > > | < | | | > | | | | | > | | | | < > | | | < | > | | < | < | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: return.n,v 1.3.18.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH return n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME return \- Return from a procedure .SH SYNOPSIS \fBreturn \fR?\fB\-code \fIcode\fR? ?\fB\-errorinfo \fIinfo\fR? ?\fB\-errorcode\fI code\fR? ?\fIstring\fR? .BE .SH DESCRIPTION .PP Return immediately from the current procedure (or top-level command or \fBsource\fR command), with \fIstring\fR as the return value. If \fIstring\fR is not specified then an empty string will be returned as result. .SH "EXCEPTIONAL RETURN CODES" .PP In addition to the result of a procedure, the return code of a procedure may also be set by \fBreturn\fR through use of the \fB-code\fR option. In the usual case where the \fB\-code\fR option isn't specified the procedure will return normally. However, the \fB\-code\fR option may be used to generate an exceptional return from the procedure. \fICode\fR may have any of the following values: .TP 13 \fBok (or 0)\fR Normal return: same as if the option is omitted. The return code of the procedure is 0 (\fBTCL_OK\fR). .TP 13 \fBerror (1)\fR Error return: the return code of the procedure is 1 (\fBTCL_ERROR\fR). The procedure command behaves in its calling context as if it were the command \fBerror \fIresult\fR. See below for additional options. .TP 13 \fBreturn (2)\fR The return code of the procedure is 2 (\fBTCL_RETURN\fR). The procedure command behaves in its calling context as if it were the command \fBreturn\fR (with no arguments). .TP 13 \fBbreak (3)\fR The return code of the procedure is 3 (\fBTCL_BREAK\fR). The procedure command behaves in its calling context as if it were the command \fBbreak\fR. .TP 13 \fBcontinue (4)\fR The return code of the procedure is 4 (\fBTCL_CONTINUE\fR). The procedure command behaves in its calling context as if it were the command \fBcontinue\fR. .TP 13 \fIvalue\fR \fIValue\fR must be an integer; it will be returned as the return code for the current procedure. .LP The \fB\-code\fR option is rarely used. It is provided so that procedures that implement new control structures can reflect exceptional conditions back to their callers. .PP Two additional options, \fB\-errorinfo\fR and \fB\-errorcode\fR, |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 | in \fBerrorInfo\fR after a \fBcatch\fR command trapped an error within the procedure. .PP If the \fB\-errorcode\fR option is specified then \fIcode\fR provides a value for the \fBerrorCode\fR variable. If the option is not specified then \fBerrorCode\fR will default to \fBNONE\fR. | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
in \fBerrorInfo\fR after a \fBcatch\fR command trapped an error within
the procedure.
.PP
If the \fB\-errorcode\fR option is specified then \fIcode\fR provides
a value for the \fBerrorCode\fR variable.
If the option is not specified then \fBerrorCode\fR will
default to \fBNONE\fR.
.SH EXAMPLES
First, a simple example of using \fBreturn\fR to return from a
procedure, interrupting the procedure body.
.CS
proc printOneLine {} {
puts "line 1" ;# This line will be printed.
\fBreturn\fR
puts "line 2" ;# This line will not be printed.
}
.CE
.PP
Next, an example of using \fBreturn\fR to set the value
returned by the procedure.
.CS
proc returnX {} {\fBreturn\fR X}
puts [returnX] ;# prints "X"
.CE
.PP
Next, a more complete example, using \fBreturn -code error\fR
to report invalid arguments.
.CS
proc factorial {n} {
if {![string is integer $n] || ($n < 0)} {
\fBreturn\fR -code error \\
"expected non-negative integer,\\
but got \\"$n\\""
}
if {$n < 2} {
\fBreturn\fR 1
}
set m [expr {$n - 1}]
set code [catch {factorial $m} factor]
if {$code != 0} {
\fBreturn\fR -code $code $factor
}
set product [expr {$n * $factor}]
if {$product < 0} {
\fBreturn\fR -code error \\
"overflow computing factorial of $n"
}
\fBreturn\fR $product
}
.CE
.PP
Next, a procedure replacement for \fBbreak\fR.
.CS
proc myBreak {} {
\fBreturn\fR -code break
}
.CE
.SH "SEE ALSO"
break(n), catch(n), continue(n), error(n), proc(n), source(n), tclvars(n)
.SH KEYWORDS
break, catch, continue, error, procedure, return
|
Changes to doc/safe.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: safe.n,v 1.4.2.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Safe\ Base \- A mechanism for creating and manipulating safe interpreters. |
| ︙ | ︙ | |||
205 206 207 208 209 210 211 | .TP \fB\-nestedLoadOk\fR This option is a convenience shortcut for \fB-nested true\fR and thus specifies the safe interpreter will be allowed to load packages into its own sub-interpreters. .TP \fB\-deleteHook\fR \fIscript\fR | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 |
.TP
\fB\-nestedLoadOk\fR
This option is a convenience shortcut for \fB-nested true\fR and
thus specifies the safe interpreter will be allowed
to load packages into its own sub-interpreters.
.TP
\fB\-deleteHook\fR \fIscript\fR
When this option is given a non-empty \fIscript\fR, it will be
evaluated in the master with the name of
the safe interpreter as an additional argument
just before actually deleting the safe interpreter.
Giving an empty value removes any currently installed deletion hook
script for that safe interpreter.
The default value (\fB{}\fR) is not to have any deletion call back.
.SH ALIASES
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 | names on the local file system thus preventing safe interpreters from gaining knowledge about the structure of the file system of the host on which the interpreter is executing. The only valid file names arguments for the \fBsource\fR and \fBload\fR aliases provided to the slave are path in the form of | | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | names on the local file system thus preventing safe interpreters from gaining knowledge about the structure of the file system of the host on which the interpreter is executing. The only valid file names arguments for the \fBsource\fR and \fBload\fR aliases provided to the slave are path in the form of \fB[file join \fR\fItoken filename\fR\fB]\fR (i.e. when using the native file path formats: \fItoken\fR\fB/\fR\fIfilename\fR on Unix, \fItoken\fR\fB\\\fIfilename\fR on Windows, and \fItoken\fR\fB:\fR\fIfilename\fR on the Mac), where \fItoken\fR is representing one of the directories of the \fIaccessPath\fR list and \fIfilename\fR is one file in that directory (no sub directories access are allowed). .PP |
| ︙ | ︙ | |||
334 335 336 337 338 339 340 | also be added (if not already included) to the slave access path. You can always specify a more restrictive path for which sub directories will never be searched by explicitly specifying your directory list with the \fB\-accessPath\fR flag instead of relying on this default mechanism. .PP When the \fIaccessPath\fR is changed after the first creation or | | | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 | also be added (if not already included) to the slave access path. You can always specify a more restrictive path for which sub directories will never be searched by explicitly specifying your directory list with the \fB\-accessPath\fR flag instead of relying on this default mechanism. .PP When the \fIaccessPath\fR is changed after the first creation or initialization (i.e. through \fBinterpConfigure -accessPath \fR\fIlist\fR), an \fBauto_reset\fR is automatically evaluated in the safe interpreter to synchronize its \fBauto_index\fR with the new token list. .SH "SEE ALSO" interp(n), library(n), load(n), package(n), source(n), unknown(n) .SH KEYWORDS alias, auto\-loading, auto_mkindex, load, master interpreter, safe interpreter, slave interpreter, source |
Changes to doc/scan.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: scan.n,v 1.9.2.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH scan n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME scan \- Parse string using conversion specifiers in the style of sscanf |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 | name of a variable; when a field is scanned from \fIstring\fR the result is converted back into a string and assigned to the corresponding variable. If no \fIvarName\fR variables are specified, then \fBscan\fR works in an inline manner, returning the data that would otherwise be stored in the variables as a list. In the inline case, an empty string is returned when the end of the input string is reached before any conversions have been performed. | < | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | name of a variable; when a field is scanned from \fIstring\fR the result is converted back into a string and assigned to the corresponding variable. If no \fIvarName\fR variables are specified, then \fBscan\fR works in an inline manner, returning the data that would otherwise be stored in the variables as a list. In the inline case, an empty string is returned when the end of the input string is reached before any conversions have been performed. .SH "DETAILS ON SCANNING" .PP \fBScan\fR operates by scanning \fIstring\fR and \fIformat\fR together. If the next character in \fIformat\fR is a blank or tab then it matches any number of white space characters in \fIstring\fR (including zero). Otherwise, if it isn't a \fB%\fR character then it |
| ︙ | ︙ | |||
184 185 186 187 188 189 190 | as many decimal digits as possible for \fB%d\fR, as many octal digits as possible for \fB%o\fR, and so on). The input field for a given conversion terminates either when a white-space character is encountered or when the maximum field width has been reached, whichever comes first. If a \fB*\fR is present in the conversion specifier then no variable is assigned and the next scan argument is not consumed. | < > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
as many decimal digits as possible for \fB%d\fR, as
many octal digits as possible for \fB%o\fR, and so on).
The input field for a given conversion terminates either when a
white-space character is encountered or when the maximum field
width has been reached, whichever comes first.
If a \fB*\fR is present in the conversion specifier
then no variable is assigned and the next scan argument is not consumed.
.SH "DIFFERENCES FROM ANSI SSCANF"
.PP
The behavior of the \fBscan\fR command is the same as the behavior of
the ANSI C \fBsscanf\fR procedure except for the following differences:
.IP [1]
\fB%p\fR conversion specifier is not currently supported.
.IP [2]
For \fB%c\fR conversions a single character value is
converted to a decimal string, which is then assigned to the
corresponding \fIvarName\fR;
no field width may be specified for this conversion.
.IP [3]
.VS 8.4
The \fBh\fR modifier is always ignored and the \fBl\fR and \fBL\fR
modifiers are ignored when converting real values (i.e. type
\fBdouble\fR is used for the internal representation).
.VE 8.4
.IP [4]
If the end of the input string is reached before any conversions have been
performed and no variables are given, an empty string is returned.
.SH EXAMPLES
Parse a simple color specification of the form \fI#RRGGBB\fR using
hexadecimal conversions with field sizes:
.CS
set string "#08D03F"
\fBscan\fR $string "#%2x%2x%2x" r g b
.CE
.PP
Parse a \fIHH:MM\fR time string, noting that this avoids problems with
octal numbers by forcing interpretation as decimals (if we did not
care, we would use the \fB%i\fR conversion instead):
.CS
set string "08:08" ;# *Not* octal!
if {[\fBscan\fR $string "%d:%d" hours minutes] != 2} {
error "not a valid time string"
}
# We have to understand numeric ranges ourselves...
if {$minutes < 0 || $minutes > 59} {
error "invalid number of minutes"
}
.CE
.PP
Break a string up into sequences of non-whitespace characters (note
the use of the \fB%n\fR conversion so that we get skipping over
leading whitespace correct):
.CS
set string " a string {with braced words} + leading space "
set words {}
while {[\fBscan\fR $string %s%n word length] == 2} {
lappend words $word
set string [string range $string $length end]
}
.CE
.PP
Parse a simple coordinate string, checking that it is complete by
looking for the terminating character explicitly:
.CS
set string "(5.2,-4e-2)"
# Note that the spaces before the literal parts of
# the scan pattern are significant, and that ")" is
# the Unicode character \\u0029
if {
[\fBscan\fR $string " (%f ,%f %c" x y last] != 3
|| $last != 0x0029
} then {
error "invalid coordinate string"
}
puts "X=$x, Y=$y"
.CE
.SH "SEE ALSO"
format(n), sscanf(3)
.SH KEYWORDS
conversion specifier, parse, scan
|
Changes to doc/seek.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: seek.n,v 1.5.8.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH seek n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME seek \- Change the access position for an open channel |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 65 66 67 68 69 70 | file or device does not support seeking. .PP .VS 8.1 Note that \fIoffset\fR values are byte offsets, not character offsets. Both \fBseek\fR and \fBtell\fR operate in terms of bytes, not characters, unlike \fBread\fR. .VE 8.1 .SH "SEE ALSO" file(n), open(n), close(n), gets(n), tell(n), Tcl_StandardChannels(3) .SH KEYWORDS access position, file, seek | > > > > > > > > > > > > > > > > > > > > > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | file or device does not support seeking. .PP .VS 8.1 Note that \fIoffset\fR values are byte offsets, not character offsets. Both \fBseek\fR and \fBtell\fR operate in terms of bytes, not characters, unlike \fBread\fR. .VE 8.1 .SH EXAMPLES Read a file twice: .CS set f [open file.txt] set data1 [read $f] \fBseek\fR $f 0 set data2 [read $f] close $f # $data1 == $data2 if the file wasn't updated .CE .PP Read the last 10 bytes from a file: .CS set f [open file.data] # This is guaranteed to work with binary data but # may fail with other encodings... fconfigure $f -translation binary \fBseek\fR $f -10 end set data [read $f 10] close $f .CE .SH "SEE ALSO" file(n), open(n), close(n), gets(n), tell(n), Tcl_StandardChannels(3) .SH KEYWORDS access position, file, seek |
Changes to doc/set.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: set.n,v 1.3.18.2 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH set n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME set \- Read and write variables |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | the value of \fIvarName\fR to \fIvalue\fR, creating a new variable if one doesn't already exist, and return its value. If \fIvarName\fR contains an open parenthesis and ends with a close parenthesis, then it refers to an array element: the characters before the first open parenthesis are the name of the array, and the characters between the parentheses are the index within the array. Otherwise \fIvarName\fR refers to a scalar variable. | < < < > | < < > | | > | > | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
the value of \fIvarName\fR to \fIvalue\fR, creating a new variable
if one doesn't already exist, and return its value.
If \fIvarName\fR contains an open parenthesis and ends with a
close parenthesis, then it refers to an array element: the characters
before the first open parenthesis are the name of the array,
and the characters between the parentheses are the index within the array.
Otherwise \fIvarName\fR refers to a scalar variable.
.PP
If \fIvarName\fR includes namespace qualifiers
(in the array name if it refers to an array element), or if \fIvarName\fR
is unqualified (does not include the names of any containing namespaces)
but no procedure is active,
\fIvarName\fR refers to a namespace variable
resolved according to the rules described under \fBNAME RESOLUTION\fR in
the \fBnamespace\fR manual page.
.PP
If a procedure is active and \fIvarName\fR is unqualified, then
\fIvarName\fR refers to a parameter or local variable of the procedure,
unless \fIvarName\fR was declared to resolve differently through one of the
\fBglobal\fR, \fBvariable\fR or \fBupvar\fR commands.
.SH EXAMPLES
Store a random number in the variable \fIr\fR:
.CS
\fBset\fR r [expr rand()]
.CE
.PP
Store a short message in an array element:
.CS
\fBset\fR anAry(msg) "Hello, World!"
.CE
.PP
Store a short message in an array element specified by a variable:
.CS
\fBset\fR elemName "msg"
\fBset\fR anAry($elemName) "Hello, World!"
.CE
.PP
Copy a value into the variable \fIout\fR from a variable whose name is
stored in the \fIvbl\fR (note that it is often easier to use arrays in
practice instead of doing double-dereferencing):
.CS
\fBset\fR in0 "small random"
\fBset\fR in1 "large random"
\fBset\fR vbl in[expr {rand() >= 0.5}]
\fBset\fR out [\fBset\fR $vbl]
.CE
.SH "SEE ALSO"
expr(n), global(n), namespace(n), proc(n), trace(n), unset(n), upvar(n), variable(n)
.SH KEYWORDS
read, write, variable
|
Changes to doc/socket.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 by Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1996 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 by Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: socket.n,v 1.7.2.3 2004/10/27 14:23:58 dkf Exp $ .so man.macros .TH socket n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME socket \- Open a TCP network connection .SH SYNOPSIS |
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | identifier that may be used in future invocations of commands like \fBread\fR, \fBputs\fR and \fBflush\fR. At present only the TCP network protocol is supported; future releases may include support for additional protocols. The \fBsocket\fR command may be used to open either the client or server side of a connection, depending on whether the \fB\-server\fR switch is specified. | | > > > > > > | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | identifier that may be used in future invocations of commands like \fBread\fR, \fBputs\fR and \fBflush\fR. At present only the TCP network protocol is supported; future releases may include support for additional protocols. The \fBsocket\fR command may be used to open either the client or server side of a connection, depending on whether the \fB\-server\fR switch is specified. .PP Note that the default encoding for \fIall\fR sockets is the system encoding, as returned by \fBencoding system\fR. Most of the time, you will need to use \fBfconfigure\fR to alter this to something else, such as \fIutf\-8\fR (ideal for communicating with other Tcl processes) or \fIiso8859\-1\fR (useful for many network protocols, especially the older ones). .SH "CLIENT SOCKETS" .PP If the \fB\-server\fR option is not specified, then the client side of a connection is opened and the command returns a channel identifier that can be used for both reading and writing. \fIPort\fR and \fIhost\fR specify a port to connect to; there must be a server accepting connections on this port. \fIPort\fR is an integer port number (or service name, where supported and understood by the host operating system) and \fIhost\fR is either a domain-style name such as \fBwww.tcl.tk\fR or a numerical IP address such as \fB127.0.0.1\fR. Use \fIlocalhost\fR to refer to the host on which the command is invoked. .PP The following options may also be present before \fIhost\fR to specify additional information about the connection: .TP \fB\-myaddr\fI addr\fR |
| ︙ | ︙ | |||
67 68 69 70 71 72 73 | may not yet be connected to the server, when the call to \fBsocket\fR returns. When a \fBgets\fR or \fBflush\fR is done on the socket before the connection attempt succeeds or fails, if the socket is in blocking mode, the operation will wait until the connection is completed or fails. If the socket is in nonblocking mode and a \fBgets\fR or \fBflush\fR is done on the socket before the connection attempt succeeds or fails, the operation returns immediately and \fBfblocked\fR on the socket returns 1. | < | > > | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | may not yet be connected to the server, when the call to \fBsocket\fR returns. When a \fBgets\fR or \fBflush\fR is done on the socket before the connection attempt succeeds or fails, if the socket is in blocking mode, the operation will wait until the connection is completed or fails. If the socket is in nonblocking mode and a \fBgets\fR or \fBflush\fR is done on the socket before the connection attempt succeeds or fails, the operation returns immediately and \fBfblocked\fR on the socket returns 1. .SH "SERVER SOCKETS" .PP If the \fB\-server\fR option is specified then the new socket will be a server for the port given by \fIport\fR (either an integer or a service name, where supported and understood by the host operating system; if \fIport\fR is zero, the operating system will allocate a free port to the server socket which may be discovered by using \fBfconfigure\fR to read the \fB\-sockname\fR option). Tcl will automatically accept connections to the given port. For each connection Tcl will create a new channel that may be used to communicate with the client. Tcl then invokes \fIcommand\fR with three additional arguments: the name of the new channel, the address, in network address notation, of the client's host, and the client's port number. .PP |
| ︙ | ︙ | |||
105 106 107 108 109 110 111 | new connections are opened. If the application doesn't enter the event loop, for example by invoking the \fBvwait\fR command or calling the C procedure \fBTcl_DoOneEvent\fR, then no connections will be accepted. .PP If \fIport\fR is specified as zero, the operating system will allocate an unused port for use as a server socket. The port number actually | | < | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | new connections are opened. If the application doesn't enter the event loop, for example by invoking the \fBvwait\fR command or calling the C procedure \fBTcl_DoOneEvent\fR, then no connections will be accepted. .PP If \fIport\fR is specified as zero, the operating system will allocate an unused port for use as a server socket. The port number actually allocated may be retrieved from the created server socket using the \fBfconfigure\fR command to retrieve the \fB\-sockname\fR option as described below. .SH "CONFIGURATION OPTIONS" The \fBfconfigure\fR command can be used to query several readonly configuration options for socket channels: .TP \fB\-error\fR This option gets the current error status of the given socket. This is useful when you need to determine if an asynchronous connect |
| ︙ | ︙ | |||
132 133 134 135 136 137 138 | \fB\-peername\fR This option is not supported by server sockets. For client and accepted sockets, this option returns a list of three elements; these are the address, the host name and the port to which the peer socket is connected or bound. If the host name cannot be computed, the second element of the list is identical to the address, its first element. .PP | > > > > > > > | > > > > > > > > > > > > > > | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
\fB\-peername\fR
This option is not supported by server sockets. For client and accepted
sockets, this option returns a list of three elements; these are the
address, the host name and the port to which the peer socket is connected
or bound. If the host name cannot be computed, the second element of the
list is identical to the address, its first element.
.PP
.SH "EXAMPLES"
Here is a very simple time server:
.CS
proc Server {channel clientaddr clientport} {
puts "Connection from $clientaddr registered"
puts $channel [clock format [clock seconds]]
close $channel
}
\fBsocket\fR -server Server 9900
vwait forever
.CE
.PP
And here is the corresponding client to talk to the server:
.CS
set server localhost
set sockChan [\fBsocket\fR $server 9900]
gets $sockChan line
close $sockChan
puts "The time on $server is $line"
.CE
.SH "SEE ALSO"
fconfigure(n), flush(n), open(n), read(n)
.SH KEYWORDS
bind, channel, connection, domain name, host, network address, socket, tcp
|
Changes to doc/source.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: source.n,v 1.5.18.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH source n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME source \- Evaluate a file or resource as a Tcl script |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | The \fI\-rsrc\fR and \fI\-rsrcid\fR forms of this command are only available on Macintosh computers. These versions of the command allow you to source a script from a \fBTEXT\fR resource. You may specify what \fBTEXT\fR resource to source by either name or id. By default Tcl searches all open resource files, which include the current application and any loaded C extensions. Alternatively, you may specify the \fIfileName\fR where the \fBTEXT\fR resource can be found. | > > > > > > > > > > > | > > | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
The \fI\-rsrc\fR and \fI\-rsrcid\fR forms of this command are only
available on Macintosh computers. These versions of the command
allow you to source a script from a \fBTEXT\fR resource. You may specify
what \fBTEXT\fR resource to source by either name or id. By default Tcl
searches all open resource files, which include the current
application and any loaded C extensions. Alternatively, you may
specify the \fIfileName\fR where the \fBTEXT\fR resource can be found.
.SH EXAMPLE
Run the script in the file \fBfoo.tcl\fR and then the script in the
file \fBbar.tcl\fR:
.CS
\fBsource\fR foo.tcl
\fBsource\fR bar.tcl
.CE
Alternatively:
.CS
foreach scriptFile {foo.tcl bar.tcl} {
\fBsource\fR $scriptFile
}
.CE
.SH "SEE ALSO"
file(n), cd(n), info(n)
.SH KEYWORDS
file, script
|
Changes to doc/split.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: split.n,v 1.3.18.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH split n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME split \- Split a string into a proper Tcl list |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | characters in \fIsplitChars\fR. Empty list elements will be generated if \fIstring\fR contains adjacent characters in \fIsplitChars\fR, or if the first or last character of \fIstring\fR is in \fIsplitChars\fR. If \fIsplitChars\fR is an empty string then each character of \fIstring\fR becomes a separate element of the result list. \fISplitChars\fR defaults to the standard white-space characters. | | > | > > > > | > > > > > > > > > > > > | > > > > > > > > > | > > > > > > > > > > > > > > > | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
characters in \fIsplitChars\fR.
Empty list elements will be generated if \fIstring\fR contains
adjacent characters in \fIsplitChars\fR, or if the first or last
character of \fIstring\fR is in \fIsplitChars\fR.
If \fIsplitChars\fR is an empty string then each character of
\fIstring\fR becomes a separate element of the result list.
\fISplitChars\fR defaults to the standard white-space characters.
.SH EXAMPLES
Divide up a USENET group name into its hierarchical components:
.CS
\fBsplit\fR "comp.lang.tcl.announce" .
\fI=> comp lang tcl announce\fR
.CE
.PP
See how the \fBsplit\fR command splits on \fIevery\fR character in
\fIsplitChars\fR, which can result in information loss if you are not
careful:
.CS
\fBsplit\fR "alpha beta gamma" "temp"
\fI=> al {ha b} {} {a ga} {} a\fR
.CE
.PP
Extract the list words from a string that is not a well-formed list:
.CS
\fBsplit\fR "Example with {unbalanced brace character"
\fI=> Example with \\{unbalanced brace character\fR
.CE
.PP
Split a string into its constituent characters
.CS
\fBsplit\fR "Hello world" {}
\fI=> H e l l o { } w o r l d\fR
.CE
.SH "PARSING RECORD-ORIENTED FILES"
Parse a Unix /etc/passwd file, which consists of one entry per line,
with each line consisting of a colon-separated list of fields:
.CS
## Read the file
set fid [open /etc/passwd]
set content [read $fid]
close $fid
## Split into records on newlines
set records [\fBsplit\fR $content "\\n"]
## Iterate over the records
foreach rec $records {
## Split into fields on colons
set fields [\fBsplit\fR $rec ":"]
## Assign fields to variables and print some out...
lassign $fields \\
userName password uid grp longName homeDir shell
puts "$longName uses [file tail $shell] for a login shell"
}
.CE
.SH "SEE ALSO"
join(n), list(n), string(n)
.SH KEYWORDS
list, split, string
|
Changes to doc/string.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: string.n,v 1.17.2.4 2006/12/14 14:24:22 dkf Exp $ '\" .so man.macros .TH string n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME string \- Manipulate strings |
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | empty string returns 0, otherwise and empty string will return 1 on any class. If \fB\-failindex\fR is specified, then if the function returns 0, the index in the string where the class was no longer valid will be stored in the variable named \fIvarname\fR. The \fIvarname\fR will not be set if the function returns 1. The following character classes are recognized (the class name can be abbreviated): .RS | | | | | | | | | | | | | | | | | | | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | empty string returns 0, otherwise and empty string will return 1 on any class. If \fB\-failindex\fR is specified, then if the function returns 0, the index in the string where the class was no longer valid will be stored in the variable named \fIvarname\fR. The \fIvarname\fR will not be set if the function returns 1. The following character classes are recognized (the class name can be abbreviated): .RS .IP \fBalnum\fR 12 Any Unicode alphabet or digit character. .IP \fBalpha\fR 12 Any Unicode alphabet character. .IP \fBascii\fR 12 Any character with a value less than \\u0080 (those that are in the 7\-bit ascii range). .IP \fBboolean\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR. .IP \fBcontrol\fR 12 Any Unicode control character. .IP \fBdigit\fR 12 Any Unicode digit character. Note that this includes characters outside of the [0\-9] range. .IP \fBdouble\fR 12 Any of the valid forms for a double in Tcl, with optional surrounding whitespace. In case of under/overflow in the value, 0 is returned and the \fIvarname\fR will contain \-1. .IP \fBfalse\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is false. .IP \fBgraph\fR 12 Any Unicode printing character, except space. .IP \fBinteger\fR 12 Any of the valid forms for an ordinary integer in Tcl, with optional surrounding whitespace. In case of under/overflow in the value, 0 is returned and the \fIvarname\fR will contain \-1. .IP \fBlower\fR 12 Any Unicode lower case alphabet character. .IP \fBprint\fR 12 Any Unicode printing character, including space. .IP \fBpunct\fR 12 Any Unicode punctuation character. .IP \fBspace\fR 12 Any Unicode space character. .IP \fBtrue\fR 12 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is true. .IP \fBupper\fR 12 Any upper case alphabet character in the Unicode character set. .IP \fBwordchar\fR 12 Any Unicode word character. That is any alphanumeric character, and any Unicode connector punctuation characters (e.g. underscore). .IP \fBxdigit\fR 12 Any hexadecimal digit character ([0\-9A\-Fa\-f]). .PP In the case of \fBboolean\fR, \fBtrue\fR and \fBfalse\fR, if the function will return 0, then the \fIvarname\fR will always be set to 0, due to the varied nature of a valid boolean value. .RE .TP |
| ︙ | ︙ | |||
168 169 170 171 172 173 174 | \fBstring length \fIstring\fR Returns a decimal string giving the number of characters in \fIstring\fR. Note that this is not necessarily the same as the number of bytes used to store the string. If the object is a ByteArray object (such as those returned from reading a binary encoded channel), then this will return the actual byte length of the object. .TP | | | | > > > > > > > > | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
\fBstring length \fIstring\fR
Returns a decimal string giving the number of characters in
\fIstring\fR. Note that this is not necessarily the same as the
number of bytes used to store the string. If the object is a
ByteArray object (such as those returned from reading a binary encoded
channel), then this will return the actual byte length of the object.
.TP
\fBstring map\fR ?\fB\-nocase\fR? \fImapping string\fR
Replaces substrings in \fIstring\fR based on the key-value pairs in
\fImapping\fR. \fImapping\fR is a list of \fIkey value key value ...\fR
as in the form returned by \fBarray get\fR. Each instance of a
key in the string will be replaced with its corresponding value. If
\fB\-nocase\fR is specified, then matching is done without regard to
case differences. Both \fIkey\fR and \fIvalue\fR may be multiple
characters. Replacement is done in an ordered manner, so the key
appearing first in the list will be checked first, and so on.
\fIstring\fR is only iterated over once, so earlier key replacements
will have no affect for later key matches. For example,
.RS
.CS
\fBstring map {abc 1 ab 2 a 3 1 0} 1abcaababcabababc\fR
.CE
will return the string \fB01321221\fR.
.PP
Note that if an earlier \fIkey\fR is a prefix of a later one, it will
completely mask the later one. So if the previous example is
reordered like this,
.CS
\fBstring map {1 0 ab 2 a 3 abc 1} 1abcaababcabababc\fR
.CE
it will return the string \fB02c322c222c\fR.
.RE
.TP
\fBstring match\fR ?\fB\-nocase\fR? \fIpattern\fR \fIstring\fR
See if \fIpattern\fR matches \fIstring\fR; return 1 if it does, 0 if
it doesn't. If \fB\-nocase\fR is specified, then the pattern attempts
to match against the string in a case insensitive manner. For the two
strings to match, their contents must be identical except that the
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 306 307 308 309 310 311 | \fBstring wordstart \fIstring charIndex\fR Returns the index of the first character in the word containing character \fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR may be specified as for the \fBindex\fR method. A word is considered to be any contiguous range of alphanumeric (Unicode letters or decimal digits) or underscore (Unicode connector punctuation) characters, or any single character other than these. .SH "SEE ALSO" expr(n), list(n) .SH KEYWORDS case conversion, compare, index, match, pattern, string, word, equal, ctype | > > > > > > > > > > > | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 |
\fBstring wordstart \fIstring charIndex\fR
Returns the index of the first character in the word containing
character \fIcharIndex\fR of \fIstring\fR. \fIcharIndex\fR may be
specified as for the \fBindex\fR method. A word is considered to be any
contiguous range of alphanumeric (Unicode letters or decimal digits)
or underscore (Unicode connector punctuation) characters, or any
single character other than these.
.SH EXAMPLE
Test if the string in the variable \fIstring\fR is a proper non-empty
prefix of the string \fBfoobar\fR.
.CS
set length [\fBstring length\fR $string]
if {$length == 0} {
set isPrefix 0
} else {
set isPrefix [\fBstring equal\fR -length $length $string "foobar"]
}
.CE
.SH "SEE ALSO"
expr(n), list(n)
.SH KEYWORDS
case conversion, compare, index, match, pattern, string, word, equal, ctype
|
Changes to doc/subst.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1994 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2001 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: subst.n,v 1.5.2.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH subst n 7.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME subst \- Perform backslash, command, and variable substitutions |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | .VE .SH EXAMPLES .PP When it performs its substitutions, \fIsubst\fR does not give any special treatment to double quotes or curly braces (except within command substitutions) so the script .CS | | | | | | | | | | | | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
.VE
.SH EXAMPLES
.PP
When it performs its substitutions, \fIsubst\fR does not give any
special treatment to double quotes or curly braces (except within
command substitutions) so the script
.CS
set a 44
\fBsubst\fR {xyz {$a}}
.CE
returns ``\fBxyz {44}\fR'', not ``\fBxyz {$a}\fR''
.VS 8.4
and the script
.CS
set a "p\\} q \\{r"
\fBsubst\fR {xyz {$a}}
.CE
return ``\fBxyz {p} q {r}\fR'', not ``\fBxyz {p\\} q \\{r}\fR''.
.PP
When command substitution is performed, it includes any variable
substitution necessary to evaluate the script.
.CS
set a 44
\fBsubst\fR -novariables {$a [format $a]}
.CE
returns ``\fB$a 44\fR'', not ``\fB$a $a\fR''. Similarly, when
variable substitution is performed, it includes any command
substitution necessary to retrieve the value of the variable.
.CS
proc b {} {return c}
array set a {c c [b] tricky}
\fBsubst\fR -nocommands {[b] $a([b])}
.CE
returns ``\fB[b] c\fR'', not ``\fB[b] tricky\fR''.
.PP
The continue and break exceptions allow command substitutions to
prevent substitution of the rest of the command substitution and the
rest of \fIstring\fR respectively, giving script authors more options
when processing text using \fIsubst\fR. For example, the script
.CS
\fBsubst\fR {abc,[break],def}
.CE
returns ``\fBabc,\fR'', not ``\fBabc,,def\fR'' and the script
.CS
\fBsubst\fR {abc,[continue;expr 1+2],def}
.CE
returns ``\fBabc,,def\fR'', not ``\fBabc,3,def\fR''.
.PP
Other exceptional return codes substitute the returned value
.CS
\fBsubst\fR {abc,[return foo;expr 1+2],def}
.CE
returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR'' and
.CS
\fBsubst\fR {abc,[return -code 10 foo;expr 1+2],def}
.CE
also returns ``\fBabc,foo,def\fR'', not ``\fBabc,3,def\fR''.
.VE
.SH "SEE ALSO"
Tcl(n), eval(n), break(n), continue(n)
.SH KEYWORDS
backslash substitution, command substitution, variable substitution
|
Changes to doc/switch.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: switch.n,v 1.5.18.1 2004/10/27 14:23:58 dkf Exp $ '\" .so man.macros .TH switch n 7.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME switch \- Evaluate one of several scripts, depending on a given value |
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | then the body after that is used, and so on). This feature makes it possible to share a single \fIbody\fR among several patterns. .PP Beware of how you place comments in \fBswitch\fR commands. Comments should only be placed \fBinside\fR the execution body of one of the patterns, and not intermingled with the patterns. | | | > > | > > > | | | | | | < > < > > > | < | | < | | | < | > > | | < > > < | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
then the body after that is used, and so on).
This feature makes it possible to share a single \fIbody\fR among
several patterns.
.PP
Beware of how you place comments in \fBswitch\fR commands. Comments
should only be placed \fBinside\fR the execution body of one of the
patterns, and not intermingled with the patterns.
.SH "EXAMPLES"
The \fBswitch\fR command can match against variables and not just
literals, as shown here (the result is \fI2\fR):
.CS
set foo "abc"
\fBswitch\fR abc a \- b {expr 1} $foo {expr 2} default {expr 3}
.CE
.PP
Using glob matching and the fall-through body is an alternative to
writing regular expressions with alternations, as can be seen here
(this returns \fI1\fR):
.CS
\fBswitch\fR \-glob aaab {
a*b \-
b {expr 1}
a* {expr 2}
default {expr 3}
}
.CE
.PP
Whenever nothing matches, the \fBdefault\fR clause (which must be
last) is taken. This example has a result of \fI3\fR:
.CS
\fBswitch\fR xyz {
a \-
b {
# Correct Comment Placement
expr 1
}
c {
expr 2
}
default {
expr 3
}
}
.CE
.SH "SEE ALSO"
for(n), if(n), regexp(n)
.SH KEYWORDS
switch, match, regular expression
|
Changes to doc/tcltest.n.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 2000 Ajuba Solutions '\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | '\" '\" Copyright (c) 1990-1994 The Regents of the University of California '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 1998-1999 Scriptics Corporation '\" Copyright (c) 2000 Ajuba Solutions '\" Contributions from Don Porter, NIST, 2002. (not subject to US copyright) '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: tcltest.n,v 1.38.2.6 2007/02/20 17:53:18 dgp Exp $ '\" .so man.macros .TH "tcltest" n 2.2 tcltest "Tcl Bundled Packages" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tcltest \- Test harness support code and utilities .SH SYNOPSIS .nf \fBpackage require tcltest ?2.2.5?\fR .sp \fBtcltest::test \fIname description ?option value ...?\fR \fBtcltest::test \fIname description ?constraints? body result\fR .sp \fBtcltest::loadTestedCommands\fR \fBtcltest::makeDirectory \fIname ?directory?\fR \fBtcltest::removeDirectory \fIname ?directory?\fR \fBtcltest::makeFile \fIcontents name ?directory?\fR \fBtcltest::removeFile \fIname ?directory?\fR \fBtcltest::viewFile \fIname ?directory?\fR \fBtcltest::cleanupTests \fI?runningMultipleTests?\fR \fBtcltest::runAllTests\fR .sp \fBtcltest::configure\fR \fBtcltest::configure \fIoption\fR \fBtcltest::configure \fIoption value ?option value ...?\fR \fBtcltest::customMatch \fImode command\fR \fBtcltest::testConstraint \fIconstraint ?value?\fR \fBtcltest::outputChannel \fI?channelID?\fR \fBtcltest::errorChannel \fI?channelID?\fR \fBtcltest::interpreter \fI?interp?\fR .sp \fBtcltest::debug \fI?level?\fR \fBtcltest::errorFile \fI?filename?\fR |
| ︙ | ︙ | |||
196 197 198 199 200 201 202 | \fBrunAllTests\fR This is a master command meant to run an entire suite of tests, spanning multiple files and/or directories, as governed by the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible with [\fBrunAllTests\fR]. .SH "CONFIGURATION COMMANDS" | < | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | \fBrunAllTests\fR This is a master command meant to run an entire suite of tests, spanning multiple files and/or directories, as governed by the configurable options of \fBtcltest\fR. See \fBRUNNING ALL TESTS\fR below for a complete description of the many variations possible with [\fBrunAllTests\fR]. .SH "CONFIGURATION COMMANDS" .TP \fBconfigure\fR Returns the list of configurable options supported by \fBtcltest\fR. See \fBCONFIGURABLE OPTIONS\fR below for the full list of options, their valid values, and their effect on \fBtcltest\fR operations. .TP \fBconfigure \fIoption\fR |
| ︙ | ︙ | |||
234 235 236 237 238 239 240 | to the expected result. To perform the match, the \fIscript\fR is completed with two additional words, the expected result, and the actual result, and the completed script is evaluated in the global namespace. The completed script is expected to return a boolean value indicating whether or not the results match. The built-in matching modes of [\fBtest\fR] are \fBexact\fR, \fBglob\fR, and \fBregexp\fR. | < | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 | to the expected result. To perform the match, the \fIscript\fR is completed with two additional words, the expected result, and the actual result, and the completed script is evaluated in the global namespace. The completed script is expected to return a boolean value indicating whether or not the results match. The built-in matching modes of [\fBtest\fR] are \fBexact\fR, \fBglob\fR, and \fBregexp\fR. .TP \fBtestConstraint \fIconstraint ?boolean?\fR Sets or returns the boolean value associated with the named \fIconstraint\fR. See \fBTEST CONSTRAINTS\fR below for more information. .TP \fBinterpreter\fR \fI?executableName?\fR Sets or returns the name of the executable to be [\fBexec\fR]ed by |
| ︙ | ︙ | |||
378 379 380 381 382 383 384 | the expected result, and how the compare the actual result to the expected result. Some configuration options of \fBtcltest\fR also influence how [\fBtest\fR] operates. .PP The valid options for [\fBtest\fR] are summarized: .CS .ta 0.8i | | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | the expected result, and how the compare the actual result to the expected result. Some configuration options of \fBtcltest\fR also influence how [\fBtest\fR] operates. .PP The valid options for [\fBtest\fR] are summarized: .CS .ta 0.8i \fBtest\fR \fIname\fR \fIdescription\fR ?-constraints \fIkeywordList|expression\fR? ?-setup \fIsetupScript\fR? ?-body \fItestScript\fR? ?-cleanup \fIcleanupScript\fR? ?-result \fIexpectedAnswer\fR? ?-output \fIexpectedOutput\fR? ?-errorOutput \fIexpectedError\fR? |
| ︙ | ︙ | |||
476 477 478 479 480 481 482 | the return value from script will be compared. The default value is an empty string. .TP \fB-output \fIexpectedValue\fR The \fB-output\fR attribute supplies the \fIexpectedValue\fR against which any output sent to \fBstdout\fR or [\fBoutputChannel\fR] during evaluation of the script(s) will be compared. Note that only output printed using | | | | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | the return value from script will be compared. The default value is an empty string. .TP \fB-output \fIexpectedValue\fR The \fB-output\fR attribute supplies the \fIexpectedValue\fR against which any output sent to \fBstdout\fR or [\fBoutputChannel\fR] during evaluation of the script(s) will be compared. Note that only output printed using [\fB::puts\fR] is used for comparison. If \fB-output\fR is not specified, output sent to \fBstdout\fR and [\fBoutputChannel\fR] is not processed for comparison. .TP \fB-errorOutput \fIexpectedValue\fR The \fB-errorOutput\fR attribute supplies the \fIexpectedValue\fR against which any output sent to \fBstderr\fR or [\fBerrorChannel\fR] during evaluation of the script(s) will be compared. Note that only output printed using [\fB::puts\fR] is used for comparison. If \fB-errorOutput\fR is not specified, output sent to \fBstderr\fR and [\fBerrorChannel\fR] is not processed for comparison. .TP \fB-returnCodes \fIexpectedCodeList\fR The optional \fB-returnCodes\fR attribute supplies \fIexpectedCodeList\fR, a list of return codes that may be accepted from evaluation of the \fB-body\fR script. If evaluation of the \fB-body\fR script returns |
| ︙ | ︙ | |||
512 513 514 515 516 517 518 | As long as [\fBtest\fR] is called with valid syntax and legal values for all attributes, it will not raise an error. Test failures are instead reported as output written to [\fBoutputChannel\fR]. In default operation, a successful test produces no output. The output messages produced by [\fBtest\fR] are controlled by the [\fBconfigure -verbose\fR] option as described in \fBCONFIGURABLE OPTIONS\fR below. Any output produced by the test scripts themselves should be | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 | As long as [\fBtest\fR] is called with valid syntax and legal values for all attributes, it will not raise an error. Test failures are instead reported as output written to [\fBoutputChannel\fR]. In default operation, a successful test produces no output. The output messages produced by [\fBtest\fR] are controlled by the [\fBconfigure -verbose\fR] option as described in \fBCONFIGURABLE OPTIONS\fR below. Any output produced by the test scripts themselves should be produced using [\fB::puts\fR] to [\fBoutputChannel\fR] or [\fBerrorChannel\fR], so that users of the test suite may easily capture output with the [\fBconfigure -outfile\fR] and [\fBconfigure -errfile\fR] options, and so that the \fB-output\fR and \fB-errorOutput\fR attributes work properly. .SH "TEST CONSTRAINTS" .PP Constraints are used to determine whether or not a test should be skipped. |
| ︙ | ︙ | |||
663 664 665 666 667 668 669 | is set, all those constraints are set to true. The effect is that when both options [\fBconfigure -constraints\fR] and [\fBconfigure -limitconstraints\fR] are in use, only those tests including only constraints from the [\fBconfigure -constraints\fR] list are run; all others are skipped. For example, one might set up a configuration with .CS | | | | 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 |
is set, all those constraints are set to true. The effect is that
when both options [\fBconfigure -constraints\fR] and
[\fBconfigure -limitconstraints\fR] are in use, only those tests including
only constraints from the [\fBconfigure -constraints\fR] list
are run; all others are skipped. For example, one might set
up a configuration with
.CS
\fBconfigure\fR -constraints knownBug \e
-limitconstraints true \e
-verbose pass
.CE
to run exactly those tests that exercise known bugs, and discover
whether any of them pass, indicating the bug had been fixed.
.SH "RUNNING ALL TESTS"
.PP
The single command [\fBrunAllTests\fR] is evaluated to run an entire
test suite, spanning many files and directories. The configuration
options of \fBtcltest\fR control the precise operations. The
[\fBrunAllTests\fR] command begins by printing a summary of its
configuration to [\fBoutputChannel\fR].
.PP
Test files to be evaluated are sought in the directory
[\fBconfigure -testdir\fR]. The list of files in that directory
that match any of the patterns in [\fBconfigure -file\fR] and
match none of the patterns in [\fBconfigure -notfile\fR] is generated
and sorted. Then each file will be evaluated in turn. If
[\fBconfigure -singleproc\fR] is true, then each file will
be [\fBsource\fR]d in the caller's context. If it is false,
then a copy of [\fBinterpreter\fR] will be [\fBexec\fR]d to
evaluate each file. The multi-process operation is useful
when testing can cause errors so severe that a process
terminates. Although such an error may terminate a child
process evaluating one file, the master process can continue
with the rest of the test suite. In multi-process operation,
the configuration of \fBtcltest\fR in the master process is
|
| ︙ | ︙ | |||
750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 | Do not display any debug information. .IP 1 Display information regarding whether a test is skipped because it doesn't match any of the tests that were specified using by [\fBconfigure -match\fR] (userSpecifiedNonMatch) or matches any of the tests specified by [\fBconfigure -skip\fR] (userSpecifiedSkip). Also print warnings about possible lack of cleanup or balance in test files. .IP 2 Display the flag array parsed by the command line processor, the contents of the ::env array, and all user-defined variables that exist in the current namespace as they are used. .IP 3 Display information regarding what individual procs in the test harness are doing. .RE .TP \fB-verbose \fIlevel\fR Sets the type of output verbosity desired to \fIlevel\fR, a list of zero or more of the elements \fBbody\fR, \fBpass\fR, | > | > | 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 |
Do not display any debug information.
.IP 1
Display information regarding whether a test is skipped because it
doesn't match any of the tests that were specified using by
[\fBconfigure -match\fR] (userSpecifiedNonMatch) or matches any of
the tests specified by [\fBconfigure -skip\fR] (userSpecifiedSkip). Also
print warnings about possible lack of cleanup or balance in test files.
Also print warnings about any re-use of test names.
.IP 2
Display the flag array parsed by the command line processor, the
contents of the ::env array, and all user-defined variables that exist
in the current namespace as they are used.
.IP 3
Display information regarding what individual procs in the test
harness are doing.
.RE
.TP
\fB-verbose \fIlevel\fR
Sets the type of output verbosity desired to \fIlevel\fR,
a list of zero or more of the elements \fBbody\fR, \fBpass\fR,
\fBskip\fR, \fBstart\fR, and \fBerror\fR. Default value
is \fB{body error}\fR.
Levels are defined as:
.RS
.IP "body (b)"
Display the body of failed tests
.IP "pass (p)"
Print output when a test passes
.IP "skip (s)"
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 | .SH "CREATING TEST SUITES WITH TCLTEST" .PP The fundamental element of a test suite is the individual [\fBtest\fR] command. We begin with several examples. .IP [1] Test of a script that returns normally. .CS | | | | | | 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
.SH "CREATING TEST SUITES WITH TCLTEST"
.PP
The fundamental element of a test suite is the individual [\fBtest\fR]
command. We begin with several examples.
.IP [1]
Test of a script that returns normally.
.CS
\fBtest\fR example-1.0 {normal return} {
format %s value
} value
.CE
.IP [2]
Test of a script that requires context setup and cleanup. Note the
bracing and indenting style that avoids any need for line continuation.
.CS
\fBtest\fR example-1.1 {test file existence} -setup {
set file [makeFile {} test]
} -body {
file exists $file
} -cleanup {
removeFile test
} -result 1
.CE
.IP [3]
Test of a script that raises an error.
.CS
\fBtest\fR example-1.2 {error return} -body {
error message
} -returnCodes error -result message
.CE
.IP [4]
Test with a constraint.
.CS
\fBtest\fR example-1.3 {user owns created files} -constraints {
unix
} -setup {
set file [makeFile {} test]
} -body {
file attributes $file -owner
} -cleanup {
removeFile test
|
| ︙ | ︙ | |||
921 922 923 924 925 926 927 | together, keeping tests synchronized with code changes. .PP Most of the code in the test file should be the [\fBtest\fR] commands. Use constraints to skip tests, rather than conditional evaluation of [\fBtest\fR]. That is, do this: .IP [5] .CS | | | | 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 |
together, keeping tests synchronized with code changes.
.PP
Most of the code in the test file should be the [\fBtest\fR] commands.
Use constraints to skip tests, rather than conditional evaluation
of [\fBtest\fR]. That is, do this:
.IP [5]
.CS
\fBtestConstraint\fR X [expr $myRequirement]
\fBtest\fR goodConditionalTest {} X {
# body
} result
.CE
and do not do this:
.IP [6]
.CS
if $myRequirement {
|
| ︙ | ︙ | |||
965 966 967 968 969 970 971 | .PP After all [\fBtest\fR]s in a test file, the command [\fBcleanupTests\fR] should be called. .IP [7] Here is a sketch of a sample test file illustrating those points: .CS package require tcltest 2.2 | | | | | | | | | | | | | | | | | | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 |
.PP
After all [\fBtest\fR]s in a test file, the command [\fBcleanupTests\fR]
should be called.
.IP [7]
Here is a sketch of a sample test file illustrating those points:
.CS
package require tcltest 2.2
eval \fB::tcltest::configure\fR $argv
package require example
namespace eval ::example::test {
namespace import ::tcltest::*
\fBtestConstraint\fR X [expr {...}]
variable SETUP {#common setup code}
variable CLEANUP {#common cleanup code}
\fBtest\fR example-1 {} -setup $SETUP -body {
# First test
} -cleanup $CLEANUP -result {...}
\fBtest\fR example-2 {} -constraints X -setup $SETUP -body {
# Second test; constrained
} -cleanup $CLEANUP -result {...}
\fBtest\fR example-3 {} {
# Third test; no context required
} {...}
\fBcleanupTests\fR
}
namespace delete ::example::test
.CE
.PP
The next level of organization is a full test suite, made up of several
test files. One script is used to control the entire suite. The
basic function of this script is to call [\fBrunAllTests\fR] after
doing any necessary setup. This script is usually named \fBall.tcl\fR
because that's the default name used by [\fBrunAllTests\fR] when combining
multiple test suites into one testing run.
.IP [8]
Here is a sketch of a sample test suite master script:
.CS
package require Tcl 8.4
package require tcltest 2.2
package require example
\fB::tcltest::configure\fR -testdir \
[file dirname [file normalize [info script]]]
eval \fB::tcltest::configure\fR $argv
\fB::tcltest::runAllTests\fR
.CE
.SH COMPATIBILITY
.PP
A number of commands and variables in the \fB::tcltest\fR namespace
provided by earlier releases of \fBtcltest\fR have not been documented
here. They are no longer part of the supported public interface of
\fBtcltest\fR and should not be used in new test suites. However,
to continue to support existing test suites written to the older
interface specifications, many of those deprecated commands and
variables still work as before. For example, in many circumstances,
[\fBconfigure\fR] will be automatically called shortly after
[\fBpackage require tcltest 2.1\fR] succeeds with arguments
from the variable \fB::argv\fR. This is to support test suites
that depend on the old behavior that \fBtcltest\fR was automatically
configured from command line arguments. New test files should not
depend on this, but should explicitly include
.CS
eval \fB::tcltest::configure\fR $::argv
.CE
to establish a configuration from command line arguments.
.SH "KNOWN ISSUES"
There are two known issues related to nested evaluations of [\fBtest\fR].
The first issue relates to the stack level in which test scripts are
executed. Tests nested within other tests may be executed at the same
stack level as the outermost test. For example, in the following code:
.CS
\fBtest\fR level-1.1 {level 1} {
-body {
\fBtest\fR level-2.1 {level 2} {
}
}
}
.CE
any script executed in level-2.1 may be executed at the same stack
level as the script defined for level-1.1.
.PP
In addition, while two [\fBtest\fR]s have been run, results will only
be reported by [\fBcleanupTests\fR] for tests at the same level as
test level-1.1. However, test results for all tests run prior to
level-1.1 will be available when test level-2.1 runs. What this
means is that if you try to access the test results for test level-2.1,
it will may say that 'm' tests have run, 'n' tests have
been skipped, 'o' tests have passed and 'p' tests have failed,
where 'm', 'n', 'o', and 'p' refer to tests that were run at the
same test level as test level-1.1.
.PP
Implementation of output and error comparison in the test command
depends on usage of ::puts in your application code. Output is
intercepted by redefining the ::puts command while the defined test
script is being run. Errors thrown by C procedures or printed
directly from C applications will not be caught by the test command.
Therefore, usage of the \fB-output\fR and \fB-errorOutput\fR
options to [\fBtest\fR] is useful only for pure Tcl applications
that use [\fB::puts\fR] to produce output.
.SH KEYWORDS
test, test harness, test suite
|
Changes to doc/tclvars.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: tclvars.n,v 1.13.2.3 2005/07/26 21:39:22 dgp Exp $ '\" .so man.macros .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclvars \- Variables used by Tcl |
| ︙ | ︙ | |||
106 107 108 109 110 111 112 | implementation of the env mechanisms. This file contains many #define's that allow customization of the env mechanisms to fit your applications needs. .RE .TP \fBerrorCode\fR After an error has occurred, this variable will be set to hold | | | < | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 | implementation of the env mechanisms. This file contains many #define's that allow customization of the env mechanisms to fit your applications needs. .RE .TP \fBerrorCode\fR After an error has occurred, this variable will be set to hold a list value representing additional information about the error in a form that is easy to process with programs. The first element of the list identifies a general class of errors, and determines the format of the rest of the list. The following formats for \fBerrorCode\fR are used by the Tcl core; individual applications may define additional formats. .RS .TP \fBARITH\fI code msg\fR |
| ︙ | ︙ | |||
243 244 245 246 247 248 249 | the platform on which the application is running, such as the name of the operating system, its current release number, and the machine's instruction set. The elements listed below will always be defined, but they may have empty strings as values if Tcl couldn't retrieve any relevant information. In addition, extensions and applications may add additional values to the array. The predefined elements are: | < | | | | > | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | the platform on which the application is running, such as the name of the operating system, its current release number, and the machine's instruction set. The elements listed below will always be defined, but they may have empty strings as values if Tcl couldn't retrieve any relevant information. In addition, extensions and applications may add additional values to the array. The predefined elements are: .RS .VS .TP \fBbyteOrder\fR The native byte order of this machine: either \fBlittleEndian\fR or \fBbigEndian\fR. .VE .TP \fBdebug\fR If this variable exists, then the interpreter was compiled with and linked to a debug-enabled C run-time. This variable will only exist on Windows, so extension writers can specify which package to load depending on the C run-time library that is in use. This is not an indication that this core contains symbols. .TP \fBmachine\fR The instruction set executed by this machine, such as \fBintel\fR, \fBPPC\fR, \fB68k\fR, or \fBsun4m\fR. On UNIX machines, this is the value returned by \fBuname -m\fR. .TP \fBos\fR |
| ︙ | ︙ | |||
339 340 341 342 343 344 345 | application has the variable is set to \fBtclshrc\fR. .TP \fBtcl_traceCompile\fR The value of this variable can be set to control how much tracing information is displayed during bytecode compilation. By default, tcl_traceCompile is zero and no information is displayed. | | | | | | | | | | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 | application has the variable is set to \fBtclshrc\fR. .TP \fBtcl_traceCompile\fR The value of this variable can be set to control how much tracing information is displayed during bytecode compilation. By default, tcl_traceCompile is zero and no information is displayed. Setting tcl_traceCompile to 1 generates a one-line summary in stdout whenever a procedure or top-level command is compiled. Setting it to 2 generates a detailed listing in stdout of the bytecode instructions emitted during every compilation. This variable is useful in tracking down suspected problems with the Tcl compiler. It is also occasionally useful when converting existing code to use Tcl8.0. .PP This variable and functionality only exist if \fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation. .TP \fBtcl_traceExec\fR The value of this variable can be set to control how much tracing information is displayed during bytecode execution. By default, tcl_traceExec is zero and no information is displayed. Setting tcl_traceExec to 1 generates a one-line trace in stdout on each call to a Tcl procedure. Setting it to 2 generates a line of output whenever any Tcl command is invoked that contains the name of the command and its arguments. Setting it to 3 produces a detailed trace showing the result of executing each bytecode instruction. Note that when tcl_traceExec is 2 or 3, commands such as \fBset\fR and \fBincr\fR that have been entirely replaced by a sequence of bytecode instructions are not shown. Setting this variable is useful in tracking down suspected problems with the bytecode compiler and interpreter. It is also occasionally useful when converting code to use Tcl8.0. .PP This variable and functionality only exist if \fBTCL_COMPILE_DEBUG\fR was defined during Tcl's compilation. .TP \fBtcl_wordchars\fR The value of this variable is a regular expression that can be set to control what are considered ``word'' characters, for instances like selecting a word by double-clicking in text in Tk. It is platform dependent. On Windows, it defaults to \fB\\S\fR, meaning anything but a Unicode space character. Otherwise it defaults to \fB\\w\fR, |
| ︙ | ︙ | |||
400 401 402 403 404 405 406 407 408 | When an interpreter is created Tcl initializes this variable to hold the version number for this version of Tcl in the form \fIx.y\fR. Changes to \fIx\fR represent major changes with probable incompatibilities and changes to \fIy\fR represent small enhancements and bug fixes that retain backward compatibility. The value of this variable is returned by the \fBinfo tclversion\fR command. .SH "SEE ALSO" | > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 | When an interpreter is created Tcl initializes this variable to hold the version number for this version of Tcl in the form \fIx.y\fR. Changes to \fIx\fR represent major changes with probable incompatibilities and changes to \fIy\fR represent small enhancements and bug fixes that retain backward compatibility. The value of this variable is returned by the \fBinfo tclversion\fR command. .SH "OTHER GLOBAL VARIABLES" The following variables are only guaranteed to exist in \fBtclsh\fR and \fBwish\fR executables; the Tcl library does not define them itself but many Tcl environments do. .TP 6 \fBargc\fR The number of arguments to \fBtclsh\fR or \fBwish\fR. .TP 6 \fBargv\fR Tcl list of arguments to \fBtclsh\fR or \fBwish\fR. .TP 6 \fBargv0\fR The script that \fBtclsh\fR or \fBwish\fR started executing (if it was specified) or otherwise the name by which \fBtclsh\fR or \fBwish\fR was invoked. .TP 6 \fBtcl_interactive\fR Contains 1 if \fBtclsh\fR or \fBwish\fR is running interactively (no script was specified and standard input is a terminal-like device), 0 otherwise. .PP The \fBwish\fR executably additionally specifies the following global variable: .TP 6 \fBgeometry\fR If set, contains the user-supplied geometry specification to use for the main Tk window. .SH "SEE ALSO" eval(n), tclsh(1), wish(1) .SH KEYWORDS arithmetic, bytecode, compiler, error, environment, POSIX, precision, subprocess, variables |
Changes to doc/tell.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: tell.n,v 1.5.8.1 2004/10/27 14:43:14 dkf Exp $ '\" .so man.macros .TH tell n 8.1 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tell \- Return current access position for an open channel |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 37 38 39 40 41 42 | .PP .VS \fIChannelId\fR must be an identifier for an open channel such as a Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR), the return value from an invocation of \fBopen\fR or \fBsocket\fR, or the result of a channel creation command provided by a Tcl extension. .VE .SH "SEE ALSO" file(n), open(n), close(n), gets(n), seek(n), Tcl_StandardChannels(3) .SH KEYWORDS access position, channel, seeking | > > > > > > > > > > > > > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
.PP
.VS
\fIChannelId\fR must be an identifier for an open channel such as a
Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
the result of a channel creation command provided by a Tcl extension.
.VE
.SH EXAMPLE
Read a line from a file channel only if it starts with \fBfoobar\fR:
.CS
# Save the offset in case we need to undo the read...
set offset [\fBtell\fR $chan]
if {[read $chan 6] eq "foobar"} {
gets $chan line
} else {
set line {}
# Undo the read...
seek $chan $offset
}
.CE
.SH "SEE ALSO"
file(n), open(n), close(n), gets(n), seek(n), Tcl_StandardChannels(3)
.SH KEYWORDS
access position, channel, seeking
|
Changes to doc/time.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: time.n,v 1.3.18.1 2004/10/27 14:43:14 dkf Exp $ '\" .so man.macros .TH time n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME time \- Time the execution of a script |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 | specified). It will then return a string of the form .CS \fB503 microseconds per iteration\fR .CE which indicates the average amount of time required per iteration, in microseconds. Time is measured in elapsed time, not CPU time. .SH "SEE ALSO" clock(n) .SH KEYWORDS script, time | > > > > > > > > > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
specified). It will then return a string of the form
.CS
\fB503 microseconds per iteration\fR
.CE
which indicates the average amount of time required per iteration,
in microseconds.
Time is measured in elapsed time, not CPU time.
.SH EXAMPLE
Estimate how long it takes for a simple Tcl \fBfor\fR loop to count to
a thousand:
.CS
time {
for {set i 0} {$i<1000} {incr i} {
# empty body
}
}
.CE
.SH "SEE ALSO"
clock(n)
.SH KEYWORDS
script, time
|
Changes to doc/trace.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: trace.n,v 1.13.2.2 2004/10/27 14:43:14 dkf Exp $ '\" .so man.macros .TH trace n "8.4" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME trace \- Monitor variable accesses, command usages and command executions |
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | command will not cause further trace evaluations to occur. Both \fIoldName\fR and \fInewName\fR are fully qualified with any namespace(s) in which they appear. .RE .TP \fBtrace add execution\fR \fIname ops command\fR Arrange for \fIcommand\fR to be executed whenever command \fIname\fR | > | | | | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
command will not cause further trace evaluations to occur.
Both \fIoldName\fR and \fInewName\fR are fully qualified with any namespace(s)
in which they appear.
.RE
.TP
\fBtrace add execution\fR \fIname ops command\fR
Arrange for \fIcommand\fR to be executed whenever command \fIname\fR
is executed, with traces occurring at the points indicated by the list
\fIops\fR. \fIName\fR will be
resolved using the usual namespace resolution rules used by
procedures. If the command does not exist, an error will be thrown.
.RS
.PP
\fIOps\fR indicates which operations are of interest, and is a list of
one or more of the following items:
.TP
\fBenter\fR
Invoke \fIcommand\fR whenever the command \fIname\fR is executed,
just before the actual execution takes place.
.TP
\fBleave\fR
Invoke \fIcommand\fR whenever the command \fIname\fR is executed,
just after the actual execution takes place.
.TP
\fBenterstep\fR
Invoke \fIcommand\fR for every Tcl command which is executed
inside the procedure \fIname\fR, just before the actual execution
takes place. For example if we have 'proc foo {} { puts "hello" }',
then an \fIenterstep\fR trace would be
invoked just before \fIputs "hello"\fR is executed.
Setting an \fIenterstep\fR trace on a \fIcommand\fR
will not result in an error and is simply ignored.
.TP
\fBleavestep\fR
Invoke \fIcommand\fR for every Tcl command which is executed
inside the procedure \fIname\fR, just after the actual execution
takes place.
Setting a \fIleavestep\fR trace on a \fIcommand\fR
will not result in an error and is simply ignored.
.PP
When the trace triggers, depending on the operations being traced, a
number of arguments are appended to \fIcommand\fR so that the actual
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 | \fIOp\fR indicates what operation is being performed on the command execution, and is one of \fBleave\fR or \fBleavestep\fR as defined above. Note that the creation of many \fBenterstep\fR or \fBleavestep\fR traces can lead to unintuitive results, since the invoked commands from one trace can themselves lead to further command invocations for other traces. | | | | | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | \fIOp\fR indicates what operation is being performed on the command execution, and is one of \fBleave\fR or \fBleavestep\fR as defined above. Note that the creation of many \fBenterstep\fR or \fBleavestep\fR traces can lead to unintuitive results, since the invoked commands from one trace can themselves lead to further command invocations for other traces. .PP \fICommand\fR executes in the same context as the code that invoked the traced operation: thus the \fIcommand\fR, if invoked from a procedure, will have access to the same local variables as code in the procedure. This context may be different than the context in which the trace was created. If \fIcommand\fR invokes a procedure (which it normally does) then the procedure will have to use upvar or uplevel commands if it wishes to access the local variables of the code which invoked the trace operation. .PP While \fIcommand\fR is executing during an execution trace, traces on \fIname\fR are temporarily disabled. This allows the \fIcommand\fR to execute \fIname\fR in its body without invoking any other traces again. If an error occurs while executing the \fIcommand\fR body, then the command \fIname\fR as a whole will return that same error. .PP When multiple traces are set on \fIname\fR, then for \fIenter\fR and \fIenterstep\fR operations, the traced commands are invoked in the reverse order of how the traces were originally created; and for \fIleave\fR and \fIleavestep\fR operations, the traced commands are invoked in the original order of creation. .PP The behavior of execution traces is currently undefined for a command \fIname\fR imported into another namespace. .RE .TP \fBtrace add variable\fI name ops command\fR Arrange for \fIcommand\fR to be executed whenever variable \fIname\fR is accessed in one of the ways given by the list \fIops\fR. \fIName\fR may |
| ︙ | ︙ | |||
349 350 351 352 353 354 355 356 357 358 359 360 361 | .PP These subcommands are deprecated and will likely be removed in a future version of Tcl. They use an older syntax in which \fBarray\fR, \fBread\fR, \fBwrite\fR, \fBunset\fR are replaced by \fBa\fR, \fBr\fR, \fBw\fR and \fBu\fR respectively, and the \fIops\fR argument is not a list, but simply a string concatenation of the operations, such as \fBrwua\fR. .SH "SEE ALSO" set(n), unset(n) .SH KEYWORDS read, command, rename, variable, write, trace, unset | > > > > > > > > > > > > > > > > > > > > > > > | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 |
.PP
These subcommands are deprecated and will likely be removed in a
future version of Tcl. They use an older syntax in which \fBarray\fR,
\fBread\fR, \fBwrite\fR, \fBunset\fR are replaced by \fBa\fR, \fBr\fR,
\fBw\fR and \fBu\fR respectively, and the \fIops\fR argument is not a
list, but simply a string concatenation of the operations, such as
\fBrwua\fR.
.SH EXAMPLES
Print a message whenever either of the global variables \fBfoo\fR and
\fBbar\fR are updated, even if they have a different local name at the
time (which can be done with the \fBupvar\fR command):
.CS
proc tracer {varname args} {
upvar #0 $varname var
puts "$varname was updated to be \e"$var\e""
}
\fBtrace add\fR variable foo write "tracer foo"
\fBtrace add\fR variable bar write "tracer bar"
.CE
.PP
Ensure that the global variable \fBfoobar\fR always contains the
product of the global variables \fBfoo\fR and \fBbar\fR:
.CS
proc doMult args {
global foo bar foobar
set foobar [expr {$foo * $bar}]
}
\fBtrace add\fR variable foo write doMult
\fBtrace add\fR variable bar write doMult
.CE
.SH "SEE ALSO"
set(n), unset(n)
.SH KEYWORDS
read, command, rename, variable, write, trace, unset
|
Changes to doc/unknown.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: unknown.n,v 1.4.12.1 2004/10/27 14:43:15 dkf Exp $ '\" .so man.macros .TH unknown n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unknown \- Handle attempts to use non-existent commands |
| ︙ | ︙ | |||
67 68 69 70 71 72 73 74 75 76 77 78 79 | If the global variable \fBauto_noload\fR is defined, then the auto-load step is skipped. If the global variable \fBauto_noexec\fR is defined then the auto-exec step is skipped. Under normal circumstances the return value from \fBunknown\fR is the return value from the command that was eventually executed. .SH "SEE ALSO" info(n), proc(n), interp(n), library(n) .SH KEYWORDS error, non-existent command | > > > > > > > > > > > > > > | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
If the global variable \fBauto_noload\fR is defined, then the auto-load
step is skipped.
If the global variable \fBauto_noexec\fR is defined then the
auto-exec step is skipped.
Under normal circumstances the return value from \fBunknown\fR
is the return value from the command that was eventually
executed.
.SH EXAMPLE
Arrange for the \fBunknown\fR command to have its standard behavior
except for first logging the fact that a command was not found:
.PP
.CS
# Save the original one so we can chain to it
rename \fBunknown\fR _original_unknown
# Provide our own implementation
proc \fBunknown\fR args {
puts stderr "WARNING: unknown command: $args"
uplevel 1 [list _original_unknown {expand}$args]
}
.CE
.SH "SEE ALSO"
info(n), proc(n), interp(n), library(n)
.SH KEYWORDS
error, non-existent command
|
Changes to doc/unset.n.
1 2 3 4 5 6 7 8 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" Copyright (c) 2000 Ajuba Solutions. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: unset.n,v 1.5.18.2 2004/10/27 14:43:15 dkf Exp $ '\" .so man.macros .TH unset n 8.4 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME unset \- Delete variables |
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | indicates the end of the options, and should be used if you wish to remove a variable with the same name as any of the options. .VE 8.4 If an error occurs, any variables after the named one causing the error not deleted. An error can occur when the named variable doesn't exist, or the name refers to an array element but the variable is a scalar, or the name refers to a variable in a non-existent namespace. | > > > > > > > > > > | > > > > > > > > > > > | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
indicates the end of the options, and should be used if you wish to
remove a variable with the same name as any of the options.
.VE 8.4
If an error occurs, any variables after the named one causing the error not
deleted. An error can occur when the named variable doesn't exist, or the
name refers to an array element but the variable is a scalar, or the name
refers to a variable in a non-existent namespace.
.SH EXAMPLE
Create an array containing a mapping from some numbers to their
squares and remove the array elements for non-prime numbers:
.CS
array set squares {
1 1 6 36
2 4 7 49
3 9 8 64
4 16 9 81
5 25 10 100
}
puts "The squares are:"
parray squares
\fBunset\fR squares(1) squares(4) squares(6)
\fBunset\fR squares(8) squares(9) squares(10)
puts "The prime squares are:"
parray squares
.CE
.SH "SEE ALSO"
set(n), trace(n), upvar(n)
.SH KEYWORDS
remove, variable
|
Changes to doc/update.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1990-1992 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1990-1992 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: update.n,v 1.4.18.1 2004/10/27 14:43:15 dkf Exp $ '\" .so man.macros .TH update n 7.5 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME update \- Process pending events and idle callbacks |
| ︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 | these updates will not occur in \fBupdate idletasks\fR. .PP The \fBupdate\fR command with no options is useful in scripts where you are performing a long-running computation but you still want the application to respond to events such as user interactions; if you occasionally call \fBupdate\fR then user input will be processed during the next call to \fBupdate\fR. .SH "SEE ALSO" after(n), bgerror(n) .SH KEYWORDS event, flush, handler, idle, update | > > > > > > > > > > > > > > > > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
these updates will not occur in \fBupdate idletasks\fR.
.PP
The \fBupdate\fR command with no options is useful in scripts where
you are performing a long-running computation but you still want
the application to respond to events such as user interactions; if
you occasionally call \fBupdate\fR then user input will be processed
during the next call to \fBupdate\fR.
.SH EXAMPLE
Run computations for about a second and then finish:
.CS
set x 1000
set done 0
after 1000 set done 1
while {!$done} {
# A very silly example!
set x [expr {log($x) ** 2.8}]
# Test to see if our time-limit has been hit. This would
# also give a chance for serving network sockets and, if
# the Tk package is loaded, updating a user interface.
\fBupdate\fR
}
.CE
.SH "SEE ALSO"
after(n), bgerror(n)
.SH KEYWORDS
event, flush, handler, idle, update
|
Changes to doc/uplevel.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: uplevel.n,v 1.3.18.1 2004/10/27 14:43:15 dkf Exp $ '\" .so man.macros .TH uplevel n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME uplevel \- Execute a script in a different stack frame |
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | If \fIlevel\fR is \fB3\fR or \fB#0\fR then the command will be executed at top-level (only global variables will be visible). .PP The \fBuplevel\fR command causes the invoking procedure to disappear from the procedure calling stack while the command is being executed. In the above example, suppose \fBc\fR invokes the command .CS | | | > > > > > > > > > > > > > > > > > > > > | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
If \fIlevel\fR is \fB3\fR or \fB#0\fR then the command will be executed
at top-level (only global variables will be visible).
.PP
The \fBuplevel\fR command causes the invoking procedure to disappear
from the procedure calling stack while the command is being executed.
In the above example, suppose \fBc\fR invokes the command
.CS
\fBuplevel\fR 1 {set x 43; d}
.CE
where \fBd\fR is another Tcl procedure. The \fBset\fR command will
modify the variable \fBx\fR in \fBb\fR's context, and \fBd\fR will execute
at level 3, as if called from \fBb\fR. If it in turn executes
the command
.CS
\fBuplevel\fR {set x 42}
.CE
then the \fBset\fR command will modify the same variable \fBx\fR in \fBb\fR's
context: the procedure \fBc\fR does not appear to be on the call stack
when \fBd\fR is executing. The command ``\fBinfo level\fR'' may
be used to obtain the level of the current procedure.
.PP
\fBUplevel\fR makes it possible to implement new control
constructs as Tcl procedures (for example, \fBuplevel\fR could
be used to implement the \fBwhile\fR construct as a Tcl procedure).
.PP
\fBnamespace eval\fR is another way (besides procedure calls)
that the Tcl naming context can change.
It adds a call frame to the stack to represent the namespace context.
This means each \fBnamespace eval\fR command
counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
For example, \fBinfo level 1\fR will return a list
describing a command that is either
the outermost procedure call or the outermost \fBnamespace eval\fR command.
Also, \fBuplevel #0\fR evaluates a script
at top-level in the outermost namespace (the global namespace).
.SH EXAMPLE
As stated above, the \fBuplevel\fR command is useful for creating new
control constructs. This example shows how (without error handling)
it can be used to create a \fBdo\fR command that is the counterpart of
\fBwhile\fR except for always performing the test after running the
loop body:
.CS
proc do {body while condition} {
if {$while ne "while"} {
error "required word missing"
}
set conditionCmd [list expr $condition]
while {1} {
\fBuplevel\fR 1 $body
if {![\fBuplevel\fR 1 $conditionCmd]} {
break
}
}
}
.CE
.SH "SEE ALSO"
namespace(n), upvar(n)
.SH KEYWORDS
context, level, namespace, stack frame, variables
|
Changes to doc/upvar.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: upvar.n,v 1.5.18.2 2004/11/12 09:02:30 das Exp $ '\" .so man.macros .TH upvar n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME upvar \- Create link to variable in a different stack frame |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | \fBUpvar\fR returns an empty string. .PP The \fBupvar\fR command simplifies the implementation of call-by-name procedure calling and also makes it easier to build new control constructs as Tcl procedures. For example, consider the following procedure: .CS | | | | < > | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
\fBUpvar\fR returns an empty string.
.PP
The \fBupvar\fR command simplifies the implementation of call-by-name
procedure calling and also makes it easier to build new control constructs
as Tcl procedures.
For example, consider the following procedure:
.CS
proc add2 name {
\fBupvar\fR $name x
set x [expr $x+2]
}
.CE
\fBadd2\fR is invoked with an argument giving the name of a variable,
and it adds two to the value of that variable.
Although \fBadd2\fR could have been implemented using \fBuplevel\fR
instead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fBadd2\fR
to access the variable in the caller's procedure frame.
.PP
\fBnamespace eval\fR is another way (besides procedure calls)
that the Tcl naming context can change.
|
| ︙ | ︙ | |||
71 72 73 74 75 76 77 | .VS If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the \fBunset\fR operation affects the variable it is linked to, not the upvar variable. There is no way to unset an upvar variable except by exiting the procedure in which it is defined. However, it is possible to retarget an upvar variable by executing another \fBupvar\fR command. | | < | | | | | | | < > | > > > > > > > > > | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
.VS
If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the
\fBunset\fR operation affects the variable it is linked to, not the
upvar variable. There is no way to unset an upvar variable except
by exiting the procedure in which it is defined. However, it is
possible to retarget an upvar variable by executing another \fBupvar\fR
command.
.SH "TRACES AND UPVAR"
.PP
Upvar interacts with traces in a straightforward but possibly
unexpected manner. If a variable trace is defined on \fIotherVar\fR, that
trace will be triggered by actions involving \fImyVar\fR. However,
the trace procedure will be passed the name of \fImyVar\fR, rather
than the name of \fIotherVar\fR. Thus, the output of the following code
will be \fBlocalVar\fR rather than \fBoriginalVar\fR:
.CS
proc \fBtraceproc\fR { name index op } {
puts $name
}
proc \fBsetByUpvar\fR { name value } {
\fBupvar\fR $name localVar
set localVar $value
}
set originalVar 1
trace variable originalVar w \fBtraceproc\fR
\fBsetByUpvar\fR originalVar 2
}
.CE
.PP
If \fIotherVar\fR refers to an element of an array, then variable
traces set for the entire array will not be invoked when \fImyVar\fR
is accessed (but traces on the particular element will still be
invoked). In particular, if the array is \fBenv\fR, then changes
made to \fImyVar\fR will not be passed to subprocesses correctly.
.VE
.SH EXAMPLE
A \fBdecr\fR command that works like \fBincr\fR except it subtracts
the value from the variable instead of adding it:
.CS
proc decr {varName {decrement 1}} {
\fBupvar\fR 1 $varName var
incr var [expr {-$decrement}]
}
.CE
.SH "SEE ALSO"
global(n), namespace(n), uplevel(n), variable(n)
.SH KEYWORDS
context, frame, global, level, namespace, procedure, variable
|
Changes to doc/variable.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies '\" Copyright (c) 1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: variable.n,v 1.4.18.2 2005/02/16 18:53:02 msofer Exp $ '\" .so man.macros .TH variable n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME variable \- create and initialize a namespace variable |
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | the variable is created in the specified namespace. If the variable is not defined, it will be visible to the \fBnamespace which\fR command, but not to the \fBinfo exists\fR command. .PP If the \fBvariable\fR command is executed inside a Tcl procedure, it creates local variables linked to the corresponding namespace variables (and therefore these | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
the variable is created in the specified namespace. If the variable
is not defined, it will be visible to the \fBnamespace which\fR
command, but not to the \fBinfo exists\fR command.
.PP
If the \fBvariable\fR command is executed inside a Tcl procedure,
it creates local variables
linked to the corresponding namespace variables (and therefore these
variables are listed by \fBinfo vars\fR.)
In this way the \fBvariable\fR command resembles the \fBglobal\fR command,
although the \fBglobal\fR command
only links to variables in the global namespace.
If any \fIvalue\fRs are given,
they are used to modify the values of the associated namespace variables.
If a namespace variable does not exist,
it is created and optionally initialized.
.PP
A \fIname\fR argument cannot reference an element within an array.
Instead, \fIname\fR should reference the entire array,
and the initialization \fIvalue\fR should be left off.
After the variable has been declared,
elements within the array can be set using ordinary
\fBset\fR or \fBarray\fR commands.
.SH EXAMPLES
Create a variable in a namespace:
.CS
namespace eval foo {
\fBvariable\fR bar 12345
}
.CE
.PP
Create an array in a namespace:
.CS
namespace eval someNS {
\fBvariable\fR someAry
array set someAry {
someName someValue
otherName otherValue
}
}
.CE
.PP
Access variables in namespaces from a procedure:
.CS
namespace eval foo {
proc spong {} {
# Variable in this namespace
\fBvariable\fR bar
puts "bar is $bar"
# Variable in another namespace
\fBvariable\fR ::someNS::someAry
parray someAry
}
}
.CE
.SH "SEE ALSO"
global(n), namespace(n), upvar(n)
.SH KEYWORDS
global, namespace, procedure, variable
|
Changes to doc/vwait.n.
1 2 3 4 5 6 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" Copyright (c) 1995-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: vwait.n,v 1.4.18.1 2004/10/27 14:43:15 dkf Exp $ '\" .so man.macros .TH vwait n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME vwait \- Process events until a variable is written |
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | after \fIvarName\fR is set. This can happen if the event handler that sets \fIvarName\fR does not complete immediately. For example, if an event handler sets \fIvarName\fR and then itself calls \fBvwait\fR to wait for a different variable, then it may not return for a long time. During this time the top-level \fBvwait\fR is blocked waiting for the event handler to complete, so it cannot return either. | > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
after \fIvarName\fR is set. This can happen if the event handler
that sets \fIvarName\fR does not complete immediately. For example,
if an event handler sets \fIvarName\fR and then itself calls
\fBvwait\fR to wait for a different variable, then it may not return
for a long time. During this time the top-level \fBvwait\fR is
blocked waiting for the event handler to complete, so it cannot
return either.
.SH EXAMPLES
Run the event-loop continually until some event calls \fBexit\fR.
(You can use any variable not mentioned elsewhere, but the name
\fIforever\fR reminds you at a glance of the intent.)
.CS
\fBvwait\fR forever
.CE
.PP
Wait five seconds for a connection to a server socket, otherwise
close the socket and continue running the script:
.CS
# Initialise the state
after 5000 set state timeout
set server [socket -server accept 12345]
proc accept {args} {
global state connectionInfo
set state accepted
set connectionInfo $args
}
# Wait for something to happen
\fBvwait\fR state
# Clean up events that could have happened
close $server
after cancel set state timeout
# Do something based on how the vwait finished...
switch $state {
timeout {
puts "no connection on port 12345"
}
accepted {
puts "connection: $connectionInfo"
puts [lindex $connectionInfo 0] "Hello there!"
}
}
.CE
.SH "SEE ALSO"
global(n), update(n)
.SH KEYWORDS
event, variable, wait
|
Changes to doc/while.n.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" RCS: @(#) $Id: while.n,v 1.3.18.1 2004/10/27 14:43:15 dkf Exp $ '\" .so man.macros .TH while n "" Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME while \- Execute script repeatedly as long as a condition is met |
| ︙ | ︙ | |||
41 42 43 44 45 46 47 | enclosed in braces, variable substitutions are delayed until the expression is evaluated (before each loop iteration), so changes in the variables will be visible. For an example, try the following script with and without the braces around \fB$x<10\fR: .CS set x 0 | | | | > > > > > > > > > | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
enclosed in braces, variable substitutions are delayed until the
expression is evaluated (before
each loop iteration), so changes in the variables will be visible.
For an example, try the following script with and without the braces
around \fB$x<10\fR:
.CS
set x 0
\fBwhile\fR {$x<10} {
puts "x is $x"
incr x
}
.CE
.SH EXAMPLE
Read lines from a channel until we get to the end of the stream, and
print them out with a line-number prepended:
.CS
set lineCount 0
\fBwhile\fR {[gets $chan line] >= 0} {
puts "[incr lineCount]: $line"
}
.CE
.SH "SEE ALSO"
break(n), continue(n), for(n), foreach(n)
.SH KEYWORDS
boolean value, loop, test, while
|
Changes to generic/README.
1 2 | This directory contains Tcl source files that work on all the platforms where Tcl runs (e.g. UNIX, PCs, and Macintoshes). Platform-specific | | | | 1 2 3 4 5 | This directory contains Tcl source files that work on all the platforms where Tcl runs (e.g. UNIX, PCs, and Macintoshes). Platform-specific sources are in the directories ../unix, ../win, ../macosx, and ../mac. RCS: @(#) $Id: README,v 1.2.40.1 2005/12/02 21:13:26 dgp Exp $ |
Changes to generic/regcomp.c.
| ︙ | ︙ | |||
549 550 551 552 553 554 555 |
slist = NULL;
for (a = pre->outs; a != NULL; a = a->outchain) {
s = a->to;
for (b = s->ins; b != NULL; b = b->inchain)
if (b->from != pre)
break;
if (b != NULL) { /* must be split */
| > > > | | > | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 |
slist = NULL;
for (a = pre->outs; a != NULL; a = a->outchain) {
s = a->to;
for (b = s->ins; b != NULL; b = b->inchain)
if (b->from != pre)
break;
if (b != NULL) { /* must be split */
if (s->tmp == NULL) { /* if not already in the list */
/* (fixes bugs 505048, 230589, */
/* 840258, 504785) */
s->tmp = slist;
slist = s;
}
}
}
/* do the splits */
for (s = slist; s != NULL; s = s2) {
s2 = newstate(nfa);
copyouts(nfa, s, s2);
|
| ︙ | ︙ | |||
2155 2156 2157 2158 2159 2160 2161 |
static char * /* points to buf or constant string */
stid(t, buf, bufsize)
struct subre *t;
char *buf;
size_t bufsize;
{
/* big enough for hex int or decimal t->retry? */
| | | | 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 |
static char * /* points to buf or constant string */
stid(t, buf, bufsize)
struct subre *t;
char *buf;
size_t bufsize;
{
/* big enough for hex int or decimal t->retry? */
if (bufsize < sizeof(void*)*2 + 3 || bufsize < sizeof(t->retry)*3 + 1)
return "unable";
if (t->retry != 0)
sprintf(buf, "%d", t->retry);
else
sprintf(buf, "%p", t);
return buf;
}
#include "regc_lex.c"
#include "regc_color.c"
#include "regc_nfa.c"
#include "regc_cvec.c"
#include "regc_locale.c"
|
Changes to generic/regcustom.h.
| ︙ | ︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 | typedef Tcl_UniChar chr; /* the type itself */ typedef int pchr; /* what it promotes to */ typedef unsigned uchr; /* unsigned type that will hold a chr */ typedef int celt; /* type to hold chr, MCCE number, or NOCELT */ #define NOCELT (-1) /* celt value which is not valid chr or MCCE */ #define CHR(c) (UCHAR(c)) /* turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* turn chr digit into its value */ #define CHRBITS 16 /* bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* smallest and largest chr; the value */ #define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ /* functions operating on chr */ #define iscalnum(x) Tcl_UniCharIsAlnum(x) #define iscalpha(x) Tcl_UniCharIsAlpha(x) #define iscdigit(x) Tcl_UniCharIsDigit(x) #define iscspace(x) Tcl_UniCharIsSpace(x) | > > > > > > | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 | typedef Tcl_UniChar chr; /* the type itself */ typedef int pchr; /* what it promotes to */ typedef unsigned uchr; /* unsigned type that will hold a chr */ typedef int celt; /* type to hold chr, MCCE number, or NOCELT */ #define NOCELT (-1) /* celt value which is not valid chr or MCCE */ #define CHR(c) (UCHAR(c)) /* turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* turn chr digit into its value */ #if TCL_UTF_MAX > 3 #define CHRBITS 32 /* bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* smallest and largest chr; the value */ #define CHR_MAX 0xffffffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else #define CHRBITS 16 /* bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* smallest and largest chr; the value */ #define CHR_MAX 0xffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #endif /* functions operating on chr */ #define iscalnum(x) Tcl_UniCharIsAlnum(x) #define iscalpha(x) Tcl_UniCharIsAlpha(x) #define iscdigit(x) Tcl_UniCharIsDigit(x) #define iscspace(x) Tcl_UniCharIsSpace(x) |
| ︙ | ︙ |
Changes to generic/rege_dfa.c.
| ︙ | ︙ | |||
557 558 559 560 561 562 563 |
chr *cp;
chr *start;
{
int i;
struct sset *ss;
struct sset *p;
struct arcp ap;
| | | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 |
chr *cp;
chr *start;
{
int i;
struct sset *ss;
struct sset *p;
struct arcp ap;
struct arcp lastap = {NULL, 0}; /* silence gcc 4 warning */
color co;
ss = pickss(v, d, cp, start);
assert(!(ss->flags&LOCKED));
/* clear out its inarcs, including self-referential ones */
ap = ss->ins;
|
| ︙ | ︙ |
Changes to generic/regerror.c.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | }; /* - regerror - the interface to error numbers */ /* ARGSUSED */ size_t /* actual space needed (including NUL) */ | | | | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
};
/*
- regerror - the interface to error numbers
*/
/* ARGSUSED */
size_t /* actual space needed (including NUL) */
regerror(code, preg, errbuf, errbuf_size)
int code; /* error code, or REG_ATOI or REG_ITOA */
CONST regex_t *preg; /* associated regex_t (unused at present) */
char *errbuf; /* result buffer (unless errbuf_size==0) */
size_t errbuf_size; /* available space in errbuf, can be 0 */
{
struct rerr *r;
char *msg;
char convbuf[sizeof(unk)+50]; /* 50 = plenty for int */
size_t len;
int icode;
switch (code) {
case REG_ATOI: /* convert name to number */
for (r = rerrs; r->code >= 0; r++)
if (strcmp(r->name, errbuf) == 0)
break;
sprintf(convbuf, "%d", r->code); /* -1 for unknown */
msg = convbuf;
break;
|
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
else { /* unknown; tell him the number */
sprintf(convbuf, "REG_%u", (unsigned)icode);
msg = convbuf;
}
break;
default: /* a real, normal error code */
for (r = rerrs; r->code >= 0; r++)
| | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
else { /* unknown; tell him the number */
sprintf(convbuf, "REG_%u", (unsigned)icode);
msg = convbuf;
}
break;
default: /* a real, normal error code */
for (r = rerrs; r->code >= 0; r++)
if (r->code == code)
break;
if (r->code >= 0)
msg = r->explain;
else { /* unknown; say so */
sprintf(convbuf, unk, code);
msg = convbuf;
}
break;
}
len = strlen(msg) + 1; /* space needed, including NUL */
if (errbuf_size > 0) {
|
| ︙ | ︙ |
Changes to generic/regexec.c.
| ︙ | ︙ | |||
345 346 347 348 349 350 351 |
cfind(v, cnfa, cm)
struct vars *v;
struct cnfa *cnfa;
struct colormap *cm;
{
struct dfa *s;
struct dfa *d;
| | | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 |
cfind(v, cnfa, cm)
struct vars *v;
struct cnfa *cnfa;
struct colormap *cm;
{
struct dfa *s;
struct dfa *d;
chr *cold = NULL; /* silence gcc 4 warning */
int ret;
s = newdfa(v, &v->g->search, cm, &v->dfa1);
NOERR();
d = newdfa(v, cnfa, cm, &v->dfa2);
if (ISERR()) {
assert(d == NULL);
|
| ︙ | ︙ |
Changes to generic/regguts.h.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | #include <limits.h> #include <string.h> #endif /* assertions */ #ifndef assert # ifndef REG_DEBUG # define NDEBUG /* no assertions */ # endif #include <assert.h> #endif /* voids */ #ifndef VOID #define VOID void /* for function return values */ | > > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | #include <limits.h> #include <string.h> #endif /* assertions */ #ifndef assert # ifndef REG_DEBUG # ifndef NDEBUG # define NDEBUG /* no assertions */ # endif # endif #include <assert.h> #endif /* voids */ #ifndef VOID #define VOID void /* for function return values */ |
| ︙ | ︙ |
Changes to generic/tcl.decls.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # tcl.decls -- # # This file contains the declarations for all supported public # functions that are exported by the Tcl library via the stubs table. # This file is used to generate the tclDecls.h, tclPlatDecls.h, # tclStub.c, and tclPlatStub.c files. # # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # tcl.decls -- # # This file contains the declarations for all supported public # functions that are exported by the Tcl library via the stubs table. # This file is used to generate the tclDecls.h, tclPlatDecls.h, # tclStub.c, and tclPlatStub.c files. # # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tcl.decls,v 1.94.2.4 2006/09/22 01:26:22 andreas_kupries Exp $ library tcl # Define the tcl interface with several sub interfaces: # tclPlat - platform specific public # tclInt - generic private # tclPlatInt - platform specific private |
| ︙ | ︙ | |||
967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact, ClientData *clientDataPtr)
}
declare 273 generic {
int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name,
CONST char *version)
}
declare 274 generic {
CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact)
}
declare 275 generic {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
| > > > > | 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 |
CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact, ClientData *clientDataPtr)
}
declare 273 generic {
int Tcl_PkgProvide(Tcl_Interp *interp, CONST char *name,
CONST char *version)
}
# TIP #268: The internally used new Require function is in slot
# 573. Assuming TCL_TIP268 was activated.
declare 274 generic {
CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact)
}
declare 275 generic {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
|
| ︙ | ︙ | |||
1453 1454 1455 1456 1457 1458 1459 |
declare 411 generic {
Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(Tcl_ChannelType
*chanTypePtr)
}
# Introduced in 8.4a2
declare 412 generic {
| | | 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 |
declare 411 generic {
Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc(Tcl_ChannelType
*chanTypePtr)
}
# Introduced in 8.4a2
declare 412 generic {
int Tcl_JoinThread(Tcl_ThreadId threadId, int* result)
}
declare 413 generic {
int Tcl_IsChannelShared(Tcl_Channel channel)
}
declare 414 generic {
int Tcl_IsChannelRegistered(Tcl_Interp* interp, Tcl_Channel channel)
}
|
| ︙ | ︙ | |||
1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 |
}
# New export due to TIP#91
declare 493 generic {
Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc(
Tcl_ChannelType *chanTypePtr)
}
##############################################################################
# Define the platform specific public Tcl interface. These functions are
# only available on the designated platform.
interface tclPlat
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 |
}
# New export due to TIP#91
declare 493 generic {
Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc(
Tcl_ChannelType *chanTypePtr)
}
# Slots 494 to 553 are taken already by 8.5
# #111 - Dicts (494 ... 504)
# #59 - Config (505)
# #139 - Namespace API (506 ... 517)
# #137 - source -encoding (518)
# #121 - ExitProc (519)
# #121 - Resource Limits (520 ... 534)
# #226 - S/R Interp State (535 ... 537)
# #227 - S/G Return Opts (538 ... 539)
# #235 - Ensemble C API (540 ... 551)
# #233 - Virtualized Time (552 ... 553)
# TIP#218 (Driver Thread Actions) davygrvy/akupries ChannelType ver 4
# These slots are used by 8.5 as well.
declare 554 generic {
Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(Tcl_ChannelType *chanTypePtr)
}
# Slots 555 to 572 are taken already by 8.5
# TIP #237: Arbitrary-prec Integers (555 ... 559)
# TIP #208: 'chan' Command (560 ... 561)
# TIP #219: Channel Reflection (562 ... 565)
# TIP #237: Add. bignum support (566)
# TIP #181: 'namespace unknown' Cmd (567 ... 568)
# TIP #258: Enhanced Encodings API (569 ... 572)
# TIP#268: Extended version numbers and requirements.
# The slot is present even if TCL_TIP268 is not activated.
declare 573 generic {
int Tcl_PkgRequireProc(Tcl_Interp *interp, CONST char *name,
int objc, Tcl_Obj *CONST objv[], ClientData *clientDataPtr)
}
##############################################################################
# Define the platform specific public Tcl interface. These functions are
# only available on the designated platform.
interface tclPlat
|
| ︙ | ︙ | |||
1829 1830 1831 1832 1833 1834 1835 |
declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
CONST char *bundleName,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
}
| > > > > > > > > | 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 |
declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
CONST char *bundleName,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
}
declare 1 macosx {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
CONST char *bundleName,
CONST char *bundleVersion,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
}
|
Changes to generic/tcl.h.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | | | | < < < | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
* Copyright (c) 1994-1998 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
* Copyright (c) 2002 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tcl.h,v 1.153.2.31 2007/05/30 14:05:18 dgp Exp $
*/
#ifndef _TCL
#define _TCL
/*
* For C++ compilers, use extern "C"
*/
#ifdef __cplusplus
extern "C" {
#endif
/*
* The following defines are used to indicate the various release levels.
*/
#define TCL_ALPHA_RELEASE 0
#define TCL_BETA_RELEASE 1
#define TCL_FINAL_RELEASE 2
/*
* When version numbers change here, must also go into the following files
* and update the version numbers:
*
* library/init.tcl (only if Major.minor changes, not patchlevel) 1 LOC
* unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch)
* win/configure.in (as above)
* win/tcl.m4 (not patchlevel)
* win/makefile.vc (not patchlevel) 2 LOC
* README (sections 0 and 2)
* mac/README (2 LOC, not patchlevel)
* macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 1 LOC
* macosx/Tcl.pbproj/default.pbxuser (not patchlevel) 1 LOC
* win/README.binary (sections 0-4)
* win/README (not patchlevel) (sections 0 and 2)
* unix/tcl.spec (2 LOC Major/Minor, 1 LOC patch)
* tests/basic.test (1 LOC M/M, not patchlevel)
* tools/tcl.hpj.in (not patchlevel, for windows installer)
* tools/tcl.wse.in (for windows installer)
* tools/tclSplash.bmp (not patchlevel)
*/
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 4
#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
#define TCL_RELEASE_SERIAL 16
#define TCL_VERSION "8.4"
#define TCL_PATCH_LEVEL "8.4.16"
/*
* The following definitions set up the proper options for Windows
* compilers. We use this method because there is no autoconf equivalent.
*/
#ifndef __WIN32__
|
| ︙ | ︙ | |||
314 315 316 317 318 319 320 | #else # define VOID char #endif /* * Miscellaneous declarations. */ | < < < > > > > > > > > > > > > > > > > | 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 | #else # define VOID char #endif /* * Miscellaneous declarations. */ #ifndef _CLIENTDATA # ifndef NO_VOID typedef void *ClientData; # else typedef int *ClientData; # endif # define _CLIENTDATA #endif /* * Darwin specifc configure overrides (to support fat compiles, where * configure runs only once for multiple architectures): */ #ifdef __APPLE__ # ifdef __LP64__ # undef TCL_WIDE_INT_TYPE # define TCL_WIDE_INT_IS_LONG 1 # else /* !__LP64__ */ # define TCL_WIDE_INT_TYPE long long # undef TCL_WIDE_INT_IS_LONG # endif /* __LP64__ */ # undef HAVE_STRUCT_STAT64 #endif /* __APPLE__ */ /* * Define Tcl_WideInt to be a type that is (at least) 64-bits wide, * and define Tcl_WideUInt to be the unsigned variant of that type * (assuming that where we have one, we can have the other.) * * Also defines the following macros: * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on |
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | * and sprintf(...,"%" TCL_LL_MODIFIER "d",...). TCL_LL_MODIFIER_SIZE * is the length of the modifier string, which is "ll" on most 32-bit * Unix systems. It has to be split up like this to allow for the more * complex formats sometimes needed (e.g. in the format(n) command.) */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) | | > > > > < > > > > > > | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 | * and sprintf(...,"%" TCL_LL_MODIFIER "d",...). TCL_LL_MODIFIER_SIZE * is the length of the modifier string, which is "ll" on most 32-bit * Unix systems. It has to be split up like this to allow for the more * complex formats sometimes needed (e.g. in the format(n) command.) */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # if defined(__GNUC__) # define TCL_WIDE_INT_TYPE long long # if defined(__WIN32__) && !defined(__CYGWIN__) # define TCL_LL_MODIFIER "I64" # define TCL_LL_MODIFIER_SIZE 3 # else # define TCL_LL_MODIFIER "L" # define TCL_LL_MODIFIER_SIZE 1 # endif typedef struct stat Tcl_StatBuf; # elif defined(__WIN32__) # define TCL_WIDE_INT_TYPE __int64 # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # define TCL_LL_MODIFIER "L" # define TCL_LL_MODIFIER_SIZE 1 # else /* __BORLANDC__ */ # if _MSC_VER < 1400 || !defined(_M_IX86) typedef struct _stati64 Tcl_StatBuf; # else typedef struct _stat64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ # define TCL_LL_MODIFIER "I64" # define TCL_LL_MODIFIER_SIZE 3 # endif /* __BORLANDC__ */ # else /* __WIN32__ */ /* * Don't know what platform it is and configure hasn't discovered what * is going on for us. Try to guess... |
| ︙ | ︙ | |||
629 630 631 632 633 634 635 |
/*
* Argument descriptors for math function callbacks in expressions:
*/
typedef enum {
TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
| < < < < < | 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 |
/*
* Argument descriptors for math function callbacks in expressions:
*/
typedef enum {
TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;
typedef struct Tcl_Value {
Tcl_ValueType type; /* Indicates intValue or doubleValue is
* valid, or both. */
long intValue; /* Integer value. */
double doubleValue; /* Double-precision floating value. */
Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */
} Tcl_Value;
/*
* Forward declaration of Tcl_Obj to prevent an error when the forward
* reference to Tcl_Obj is encountered in the procedure types declared
* below.
*/
|
| ︙ | ︙ | |||
808 809 810 811 812 813 814 815 | # define Tcl_DecrRefCount(objPtr) \ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) # define Tcl_IsShared(objPtr) \ Tcl_DbIsShared(objPtr, __FILE__, __LINE__) #else # define Tcl_IncrRefCount(objPtr) \ ++(objPtr)->refCount # define Tcl_DecrRefCount(objPtr) \ | > > > | | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 |
# define Tcl_DecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
# define Tcl_IsShared(objPtr) \
Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
#else
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* Use empty if ; else to handle use in unbraced outer if/else conditions
*/
# define Tcl_DecrRefCount(objPtr) \
if (--(objPtr)->refCount > 0) ; else TclFreeObj(objPtr)
# define Tcl_IsShared(objPtr) \
((objPtr)->refCount > 1)
#endif
/*
* Macros and definitions that help to debug the use of Tcl objects.
* When TCL_MEM_DEBUG is defined, the Tcl_New declarations are
|
| ︙ | ︙ | |||
1410 1411 1412 1413 1414 1415 1416 | #define TCL_STDERR (1<<3) #define TCL_ENFORCE_MODE (1<<4) /* * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel * should be closed. */ | | > > > > > > > > | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 | #define TCL_STDERR (1<<3) #define TCL_ENFORCE_MODE (1<<4) /* * Bits passed to Tcl_DriverClose2Proc to indicate which side of a channel * should be closed. */ #define TCL_CLOSE_READ (1<<1) #define TCL_CLOSE_WRITE (1<<2) /* * Value to use as the closeProc for a channel that supports the * close2Proc interface. */ #define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)1) /* * Channel version tag. This was introduced in 8.3.2/8.4. */ #define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) #define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) #define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) /* * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc */ #define TCL_CHANNEL_THREAD_INSERT (0) #define TCL_CHANNEL_THREAD_REMOVE (1) /* * Typedefs for the various operations in a channel type: */ typedef int (Tcl_DriverBlockModeProc) _ANSI_ARGS_(( ClientData instanceData, int mode)); typedef int (Tcl_DriverCloseProc) _ANSI_ARGS_((ClientData instanceData, |
| ︙ | ︙ | |||
1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 | ClientData instanceData)); typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( ClientData instanceData, int interestMask)); typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCodePtr)); /* * The following declarations either map ckalloc and ckfree to * malloc and free, or they map them to procedures with all sorts * of debugging hooks defined in tclCkalloc.c. */ #ifdef TCL_MEM_DEBUG | > > > | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 | ClientData instanceData)); typedef int (Tcl_DriverHandlerProc) _ANSI_ARGS_(( ClientData instanceData, int interestMask)); typedef Tcl_WideInt (Tcl_DriverWideSeekProc) _ANSI_ARGS_(( ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCodePtr)); /* TIP #218, Channel Thread Actions */ typedef void (Tcl_DriverThreadActionProc) _ANSI_ARGS_ (( ClientData instanceData, int action)); /* * The following declarations either map ckalloc and ckfree to * malloc and free, or they map them to procedures with all sorts * of debugging hooks defined in tclCkalloc.c. */ #ifdef TCL_MEM_DEBUG |
| ︙ | ︙ | |||
1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 |
*/
Tcl_DriverWideSeekProc *wideSeekProc;
/* Procedure to call to seek
* on the channel which can
* handle 64-bit offsets. May be
* NULL, and must be NULL if
* seekProc is NULL. */
} Tcl_ChannelType;
/*
* The following flags determine whether the blockModeProc above should
* set the channel into blocking or nonblocking mode. They are passed
* as arguments to the blockModeProc procedure in the above structure.
*/
| > > > > > > > > > > | | | 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 |
*/
Tcl_DriverWideSeekProc *wideSeekProc;
/* Procedure to call to seek
* on the channel which can
* handle 64-bit offsets. May be
* NULL, and must be NULL if
* seekProc is NULL. */
/*
* Only valid in TCL_CHANNEL_VERSION_4 channels or later
* TIP #218, Channel Thread Actions
*/
Tcl_DriverThreadActionProc *threadActionProc;
/* Procedure to call to notify
* the driver of thread specific
* activity for a channel.
* May be NULL. */
} Tcl_ChannelType;
/*
* The following flags determine whether the blockModeProc above should
* set the channel into blocking or nonblocking mode. They are passed
* as arguments to the blockModeProc procedure in the above structure.
*/
#define TCL_MODE_BLOCKING 0 /* Put channel into blocking mode. */
#define TCL_MODE_NONBLOCKING 1 /* Put channel into nonblocking
* mode. */
/*
* Enum for different types of file paths.
*/
typedef enum Tcl_PathType {
TCL_PATH_ABSOLUTE,
|
| ︙ | ︙ | |||
1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 | #define TCL_GLOB_TYPE_BLOCK (1<<0) #define TCL_GLOB_TYPE_CHAR (1<<1) #define TCL_GLOB_TYPE_DIR (1<<2) #define TCL_GLOB_TYPE_PIPE (1<<3) #define TCL_GLOB_TYPE_FILE (1<<4) #define TCL_GLOB_TYPE_LINK (1<<5) #define TCL_GLOB_TYPE_SOCK (1<<6) #define TCL_GLOB_PERM_RONLY (1<<0) #define TCL_GLOB_PERM_HIDDEN (1<<1) #define TCL_GLOB_PERM_R (1<<2) #define TCL_GLOB_PERM_W (1<<3) #define TCL_GLOB_PERM_X (1<<4) | > | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 | #define TCL_GLOB_TYPE_BLOCK (1<<0) #define TCL_GLOB_TYPE_CHAR (1<<1) #define TCL_GLOB_TYPE_DIR (1<<2) #define TCL_GLOB_TYPE_PIPE (1<<3) #define TCL_GLOB_TYPE_FILE (1<<4) #define TCL_GLOB_TYPE_LINK (1<<5) #define TCL_GLOB_TYPE_SOCK (1<<6) #define TCL_GLOB_TYPE_MOUNT (1<<7) #define TCL_GLOB_PERM_RONLY (1<<0) #define TCL_GLOB_PERM_HIDDEN (1<<1) #define TCL_GLOB_PERM_R (1<<2) #define TCL_GLOB_PERM_W (1<<3) #define TCL_GLOB_PERM_X (1<<4) |
| ︙ | ︙ | |||
2173 2174 2175 2176 2177 2178 2179 | * TCL_ENCODING_STOPONERROR was specified. */ #define TCL_CONVERT_MULTIBYTE -1 #define TCL_CONVERT_SYNTAX -2 #define TCL_CONVERT_UNKNOWN -3 #define TCL_CONVERT_NOSPACE -4 | < | > > > > > > > > > > > > > > > > > > > > > | 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 |
* TCL_ENCODING_STOPONERROR was specified.
*/
#define TCL_CONVERT_MULTIBYTE -1
#define TCL_CONVERT_SYNTAX -2
#define TCL_CONVERT_UNKNOWN -3
#define TCL_CONVERT_NOSPACE -4
/*
* The maximum number of bytes that are necessary to represent a single
* Unicode character in UTF-8. The valid values should be 3 or 6 (or
* perhaps 1 if we want to support a non-unicode enabled core).
* If 3, then Tcl_UniChar must be 2-bytes in size (UCS-2). (default)
* If 6, then Tcl_UniChar must be 4-bytes in size (UCS-4).
* At this time UCS-2 mode is the default and recommended mode.
* UCS-4 is experimental and not recommended. It works for the core,
* but most extensions expect UCS-2.
*/
#ifndef TCL_UTF_MAX
#define TCL_UTF_MAX 3
#endif
/*
* This represents a Unicode character. Any changes to this should
* also be reflected in regcustom.h.
*/
#if TCL_UTF_MAX > 3
/*
* unsigned int isn't 100% accurate as it should be a strict 4-byte
* value (perhaps wchar_t). 64-bit systems may have troubles. The
* size of this value must be reflected correctly in regcustom.h and
* in tclEncoding.c.
* XXX: Tcl is currently UCS-2 and planning UTF-16 for the Unicode
* XXX: string rep that Tcl_UniChar represents. Changing the size
* XXX: of Tcl_UniChar is /not/ supported.
*/
typedef unsigned int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif
/*
* Deprecated Tcl procedures:
*/
#ifndef TCL_NO_DEPRECATED
# define Tcl_EvalObj(interp,objPtr) \
|
| ︙ | ︙ |
Changes to generic/tclAlloc.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 1998-1999 by Scriptics Corporation. * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | * Copyright (c) 1998-1999 by Scriptics Corporation. * * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclAlloc.c,v 1.16.2.1 2004/10/28 21:12:37 andreas_kupries Exp $ */ /* * Windows and Unix use an alternative allocator when building with threads * that has significantly reduced lock contention. */ #if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) || defined(TCL_MEM_DEBUG) #include "tclInt.h" #include "tclPort.h" #if USE_TCLALLOC #ifdef TCL_DEBUG |
| ︙ | ︙ |
Changes to generic/tclAsync.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclAsync.c,v 1.6.12.1 2006/07/11 13:18:10 vasiljevic Exp $ */ #include "tclInt.h" #include "tclPort.h" /* Forward declaration */ struct ThreadSpecificData; |
| ︙ | ︙ | |||
282 283 284 285 286 287 288 289 |
Tcl_AsyncDelete(async)
Tcl_AsyncHandler async; /* Token for handler to delete. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
AsyncHandler *asyncPtr = (AsyncHandler *) async;
AsyncHandler *prevPtr;
Tcl_MutexLock(&tsdPtr->asyncMutex);
| > > > > > > > > | | | | | | | | | | | | | > | 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
Tcl_AsyncDelete(async)
Tcl_AsyncHandler async; /* Token for handler to delete. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
AsyncHandler *asyncPtr = (AsyncHandler *) async;
AsyncHandler *prevPtr;
/*
* Conservatively check the existence of the linked list of
* registered handlers, as we may come at this point even
* when the TSD's for the current thread have been already
* garbage-collected.
*/
Tcl_MutexLock(&tsdPtr->asyncMutex);
if (tsdPtr->firstHandler != NULL ) {
if (tsdPtr->firstHandler == asyncPtr) {
tsdPtr->firstHandler = asyncPtr->nextPtr;
if (tsdPtr->firstHandler == NULL) {
tsdPtr->lastHandler = NULL;
}
} else {
prevPtr = tsdPtr->firstHandler;
while (prevPtr->nextPtr != asyncPtr) {
prevPtr = prevPtr->nextPtr;
}
prevPtr->nextPtr = asyncPtr->nextPtr;
if (tsdPtr->lastHandler == asyncPtr) {
tsdPtr->lastHandler = prevPtr;
}
}
}
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
ckfree((char *) asyncPtr);
}
/*
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclBasic.c,v 1.75.2.26 2006/11/28 22:19:59 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" #ifndef TCL_GENERIC_ONLY # include "tclPort.h" #endif |
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 | Tcl_Interp* interp, int level, CONST char* command, Tcl_Command commandInfo, int objc, Tcl_Obj *CONST objv[])); static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); extern TclStubs tclStubs; /* * The following structure defines the commands in the Tcl core. */ | > > > > > > > > > > > | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | Tcl_Interp* interp, int level, CONST char* command, Tcl_Command commandInfo, int objc, Tcl_Obj *CONST objv[])); static void StringTraceDeleteProc _ANSI_ARGS_((ClientData clientData)); #ifdef TCL_TIP280 /* TIP #280 - Modified token based evulation, with line information */ static int EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, int numBytes, int flags, int line)); static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int line)); #endif extern TclStubs tclStubs; /* * The following structure defines the commands in the Tcl core. */ |
| ︙ | ︙ | |||
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
iPtr->interpInfo = NULL;
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
iPtr->numLevels = 0;
iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
iPtr->framePtr = NULL;
iPtr->varFramePtr = NULL;
iPtr->activeVarTracePtr = NULL;
iPtr->returnCode = TCL_OK;
iPtr->errorInfo = NULL;
iPtr->errorCode = NULL;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
iPtr->cmdCount = 0;
iPtr->termOffset = 0;
TclInitLiteralTable(&(iPtr->literalTable));
iPtr->compileEpoch = 0;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
iPtr->evalFlags = 0;
iPtr->scriptFile = NULL;
iPtr->flags = 0;
iPtr->tracePtr = NULL;
iPtr->tracesForbiddingInline = 0;
iPtr->activeCmdTracePtr = NULL;
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = (Tcl_HashTable *) NULL;
iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
iPtr->resultSpace[0] = 0;
iPtr->globalNsPtr = NULL; /* force creation of global ns below */
iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
if (iPtr->globalNsPtr == NULL) {
panic("Tcl_CreateInterp: can't create global namespace");
}
| > > > > > > > > > > > > > > > > > > > > | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
iPtr->interpInfo = NULL;
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
iPtr->numLevels = 0;
iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
iPtr->framePtr = NULL;
iPtr->varFramePtr = NULL;
#ifdef TCL_TIP280
/*
* TIP #280 - Initialize the arrays used to extend the ByteCode and
* Proc structures.
*/
iPtr->cmdFramePtr = NULL;
iPtr->linePBodyPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
iPtr->lineBCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
#endif
iPtr->activeVarTracePtr = NULL;
iPtr->returnCode = TCL_OK;
iPtr->errorInfo = NULL;
iPtr->errorCode = NULL;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
#ifdef TCL_TIP268
/* TIP #268 */
iPtr->packagePrefer = (getenv ("TCL_PKG_PREFER_LATEST") == NULL ?
PKG_PREFER_STABLE :
PKG_PREFER_LATEST);
#endif
iPtr->cmdCount = 0;
iPtr->termOffset = 0;
TclInitLiteralTable(&(iPtr->literalTable));
iPtr->compileEpoch = 0;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
iPtr->evalFlags = 0;
iPtr->scriptFile = NULL;
iPtr->flags = 0;
iPtr->tracePtr = NULL;
iPtr->tracesForbiddingInline = 0;
iPtr->activeCmdTracePtr = NULL;
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = (Tcl_HashTable *) NULL;
iPtr->execEnvPtr = NULL; /* set after namespaces initialized */
iPtr->emptyObjPtr = Tcl_NewObj(); /* another empty object */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
iPtr->resultSpace[0] = 0;
iPtr->threadId = Tcl_GetCurrentThread();
iPtr->globalNsPtr = NULL; /* force creation of global ns below */
iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
if (iPtr->globalNsPtr == NULL) {
panic("Tcl_CreateInterp: can't create global namespace");
}
|
| ︙ | ︙ | |||
567 568 569 570 571 572 573 574 575 576 |
Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",
TCL_GLOBAL_ONLY);
#endif
/*
* Register Tcl's version number.
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
| > > > | > > > > > > > > | 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
Tcl_SetVar2(interp, "tcl_platform", "threaded", "1",
TCL_GLOBAL_ONLY);
#endif
/*
* Register Tcl's version number.
* TIP#268: Expose information about its status,
* for runtime switches in the core library
* and tests.
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_VERSION, (ClientData) &tclStubs);
#ifdef TCL_TIP268
Tcl_SetVar2(interp, "tcl_platform", "tip,268", "1",
TCL_GLOBAL_ONLY);
#endif
#ifdef TCL_TIP280
Tcl_SetVar2(interp, "tcl_platform", "tip,280", "1",
TCL_GLOBAL_ONLY);
#endif
#ifdef Tcl_InitStubs
#undef Tcl_InitStubs
#endif
Tcl_InitStubs(interp, TCL_VERSION, 1);
return interp;
}
|
| ︙ | ︙ | |||
644 645 646 647 648 649 650 |
Tcl_CallWhenDeleted(interp, proc, clientData)
Tcl_Interp *interp; /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
* is about to be deleted. */
ClientData clientData; /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
| > | < | < < | | < | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 |
Tcl_CallWhenDeleted(interp, proc, clientData)
Tcl_Interp *interp; /* Interpreter to watch. */
Tcl_InterpDeleteProc *proc; /* Procedure to call when interpreter
* is about to be deleted. */
ClientData clientData; /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr =
Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
int new;
char buffer[32 + TCL_INTEGER_SPACE];
AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
Tcl_HashEntry *hPtr;
sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
(*assocDataCounterPtr)++;
if (iPtr->assocData == (Tcl_HashTable *) NULL) {
iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &new);
dPtr->proc = proc;
|
| ︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 |
/*
* Free up literal objects created for scripts compiled by the
* interpreter.
*/
TclDeleteLiteralTable(interp, &(iPtr->literalTable));
ckfree((char *) iPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_HideCommand --
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 |
/*
* Free up literal objects created for scripts compiled by the
* interpreter.
*/
TclDeleteLiteralTable(interp, &(iPtr->literalTable));
#ifdef TCL_TIP280
/* TIP #280 - Release the arrays for ByteCode/Proc extension, and contents.
*/
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
CmdFrame* cfPtr;
ExtCmdLoc* eclPtr;
int i;
for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
cfPtr = (CmdFrame*) Tcl_GetHashValue (hPtr);
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (cfPtr->data.eval.path);
}
ckfree ((char*) cfPtr->line);
ckfree ((char*) cfPtr);
Tcl_DeleteHashEntry (hPtr);
}
Tcl_DeleteHashTable (iPtr->linePBodyPtr);
ckfree ((char*) iPtr->linePBodyPtr);
iPtr->linePBodyPtr = NULL;
/* See also tclCompile.c, TclCleanupByteCode */
for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hPtr);
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (eclPtr->path);
}
for (i=0; i< eclPtr->nuloc; i++) {
ckfree ((char*) eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
ckfree ((char*) eclPtr->loc);
}
ckfree ((char*) eclPtr);
Tcl_DeleteHashEntry (hPtr);
}
Tcl_DeleteHashTable (iPtr->lineBCPtr);
ckfree((char*) iPtr->lineBCPtr);
iPtr->lineBCPtr = NULL;
}
#endif
ckfree((char *) iPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_HideCommand --
|
| ︙ | ︙ | |||
1162 1163 1164 1165 1166 1167 1168 |
* But as we currently limit ourselves to the global namespace only
* for the source, in order to avoid potential confusion,
* lets prevent "::" in the token too. --dl
*/
if (strstr(hiddenCmdToken, "::") != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
| | | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
* But as we currently limit ourselves to the global namespace only
* for the source, in order to avoid potential confusion,
* lets prevent "::" in the token too. --dl
*/
if (strstr(hiddenCmdToken, "::") != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot use namespace qualifiers in hidden command",
" token (rename)", (char *) NULL);
return TCL_ERROR;
}
/*
* Find the command to hide. An error is returned if cmdName can't
* be found. Look up the command only from the global namespace.
* Full path of the command must be given if using namespaces.
|
| ︙ | ︙ | |||
1833 1834 1835 1836 1837 1838 1839 |
/*
* Create the object argument array "objv". Make sure objv is large
* enough to hold the objc arguments plus 1 extra for the zero
* end-of-objv word.
*/
| | | < | 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 |
/*
* Create the object argument array "objv". Make sure objv is large
* enough to hold the objc arguments plus 1 extra for the zero
* end-of-objv word.
*/
if (argc > NUM_ARGS) {
objv = (Tcl_Obj **)
ckalloc((unsigned)(argc * sizeof(Tcl_Obj *)));
}
for (i = 0; i < argc; i++) {
length = strlen(argv[i]);
TclNewObj(objPtr);
TclInitStringRep(objPtr, argv[i], length);
Tcl_IncrRefCount(objPtr);
objv[i] = objPtr;
}
/*
* Invoke the command's object-based Tcl_ObjCmdProc.
*/
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, argc, objv);
|
| ︙ | ︙ | |||
2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 |
* delete procs may try to avoid this (renaming the command etc).
* Also traces and delete procs may try to delete the command
* themsevles. This flag declares that a delete is in progress
* and that recursive deletes should be ignored.
*/
cmdPtr->flags |= CMD_IS_DELETED;
/*
* Call trace procedures for the command being deleted. Then delete
* its traces.
*/
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
| > > > > > > > | 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 |
* delete procs may try to avoid this (renaming the command etc).
* Also traces and delete procs may try to delete the command
* themsevles. This flag declares that a delete is in progress
* and that recursive deletes should be ignored.
*/
cmdPtr->flags |= CMD_IS_DELETED;
/*
* Bump the command epoch counter. This will invalidate all cached
* references that point to this command.
*/
cmdPtr->cmdEpoch++;
/*
* Call trace procedures for the command being deleted. Then delete
* its traces.
*/
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
|
| ︙ | ︙ | |||
2484 2485 2486 2487 2488 2489 2490 |
* this memory with free() instead of ckfree(). You should
* pass a pointer to your own method that calls ckfree().
*/
(*cmdPtr->deleteProc)(cmdPtr->deleteData);
}
| < < < < < < < | 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 |
* this memory with free() instead of ckfree(). You should
* pass a pointer to your own method that calls ckfree().
*/
(*cmdPtr->deleteProc)(cmdPtr->deleteData);
}
/*
* If this command was imported into other namespaces, then imported
* commands were created that refer back to this command. Delete these
* imported commands now.
*/
for (refPtr = cmdPtr->importRefPtr; refPtr != NULL;
|
| ︙ | ︙ | |||
2547 2548 2549 2550 2551 2552 2553 |
Interp *iPtr; /* Interpreter containing command. */
Command *cmdPtr; /* Command whose traces are to be
* invoked. */
CONST char *oldName; /* Command's old name, or NULL if we
* must get the name from cmdPtr */
CONST char *newName; /* Command's new name, or NULL if
* the command is not being renamed */
| | < < | | > > > | 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 |
Interp *iPtr; /* Interpreter containing command. */
Command *cmdPtr; /* Command whose traces are to be
* invoked. */
CONST char *oldName; /* Command's old name, or NULL if we
* must get the name from cmdPtr */
CONST char *newName; /* Command's new name, or NULL if
* the command is not being renamed */
int flags; /* Flags indicating the type of traces
* to trigger, either TCL_TRACE_DELETE
* or TCL_TRACE_RENAME. */
{
register CommandTrace *tracePtr;
ActiveCommandTrace active;
char *result;
Tcl_Obj *oldNamePtr = NULL;
int mask = (TCL_TRACE_DELETE | TCL_TRACE_RENAME); /* Safety */
flags &= mask;
if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
/*
* While a rename trace is active, we will not process any more
* rename traces; while a delete trace is active we will never
* reach here -- because Tcl_DeleteCommandFromToken checks for the
* condition (cmdPtr->flags & CMD_IS_DELETED) and returns immediately
|
| ︙ | ︙ | |||
2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 |
}
}
cmdPtr->flags |= CMD_TRACE_ACTIVE;
cmdPtr->refCount++;
result = NULL;
active.nextPtr = iPtr->activeCmdTracePtr;
iPtr->activeCmdTracePtr = &active;
if (flags & TCL_TRACE_DELETE) {
flags |= TCL_TRACE_DESTROYED;
}
active.cmdPtr = cmdPtr;
Tcl_Preserve((ClientData) iPtr);
for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
| > > > | | | | 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 |
}
}
cmdPtr->flags |= CMD_TRACE_ACTIVE;
cmdPtr->refCount++;
result = NULL;
active.nextPtr = iPtr->activeCmdTracePtr;
active.reverseScan = 0;
iPtr->activeCmdTracePtr = &active;
if (flags & TCL_TRACE_DELETE) {
flags |= TCL_TRACE_DESTROYED;
}
active.cmdPtr = cmdPtr;
Tcl_Preserve((ClientData) iPtr);
for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
int traceFlags = (tracePtr->flags & mask);
active.nextTracePtr = tracePtr->nextPtr;
if (!(traceFlags & flags)) {
continue;
}
cmdPtr->flags |= traceFlags;
if (oldName == NULL) {
TclNewObj(oldNamePtr);
Tcl_IncrRefCount(oldNamePtr);
Tcl_GetCommandFullName((Tcl_Interp *) iPtr,
(Tcl_Command) cmdPtr, oldNamePtr);
oldName = TclGetString(oldNamePtr);
}
tracePtr->refCount++;
(*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, oldName, newName, flags);
cmdPtr->flags &= ~traceFlags;
if ((--tracePtr->refCount) <= 0) {
ckfree((char*)tracePtr);
}
}
/*
* If a new object was created to hold the full oldName,
|
| ︙ | ︙ | |||
2916 2917 2918 2919 2920 2921 2922 |
}
/*
* Check depth of nested calls to Tcl_Eval: if this gets too large,
* it's probably because of an infinite loop somewhere.
*/
| | | < < | 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 |
}
/*
* Check depth of nested calls to Tcl_Eval: if this gets too large,
* it's probably because of an infinite loop somewhere.
*/
if (((iPtr->numLevels) > iPtr->maxNestingDepth)
|| (TclpCheckStackSpace() == 0)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too many nested evaluations (infinite loop?)", -1);
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclEvalObjvInternal --
*
* This procedure evaluates a Tcl command that has already been
* parsed into words, with one Tcl_Obj holding each word. The caller
* is responsible for managing the iPtr->numLevels.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR. A result or error message is left in
* interp's result. If an error occurs, this procedure does
* NOT add any information to the errorInfo variable.
*
|
| ︙ | ︙ | |||
2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 |
Tcl_Obj **newObjv;
int i;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int code = TCL_OK;
int traceCode = TCL_OK;
int checkTraces = 1;
if (objc == 0) {
return TCL_OK;
}
/*
* If any execution traces rename or delete the current command,
* we may need (at most) two passes here.
*/
while (1) {
/*
* Find the procedure to execute this command. If there isn't one,
* then see if there is a command "unknown". If so, create a new
* word array with "unknown" as the first word and the original
* command words as arguments. Then call ourselves recursively
* to execute it.
*/
| > > > > > > > > > > > > > > > > < < < < < < < < < | > > > > > > > > > | | > | < < < < < > > > > > | 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 |
Tcl_Obj **newObjv;
int i;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int code = TCL_OK;
int traceCode = TCL_OK;
int checkTraces = 1;
Namespace *savedNsPtr = NULL;
if (TclInterpReady(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (objc == 0) {
return TCL_OK;
}
/*
* If any execution traces rename or delete the current command,
* we may need (at most) two passes here.
*/
savedVarFramePtr = iPtr->varFramePtr;
while (1) {
/* Configure evaluation context to match the requested flags */
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
} else if ((flags & TCL_EVAL_INVOKE) && iPtr->varFramePtr) {
savedNsPtr = iPtr->varFramePtr->nsPtr;
iPtr->varFramePtr->nsPtr = iPtr->globalNsPtr;
}
/*
* Find the procedure to execute this command. If there isn't one,
* then see if there is a command "unknown". If so, create a new
* word array with "unknown" as the first word and the original
* command words as arguments. Then call ourselves recursively
* to execute it.
*/
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
if (cmdPtr == NULL) {
newObjv = (Tcl_Obj **) ckalloc((unsigned)
((objc + 1) * sizeof (Tcl_Obj *)));
for (i = objc-1; i >= 0; i--) {
newObjv[i+1] = objv[i];
}
newObjv[0] = Tcl_NewStringObj("::unknown", -1);
Tcl_IncrRefCount(newObjv[0]);
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
if (cmdPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid command name \"", Tcl_GetString(objv[0]), "\"",
(char *) NULL);
code = TCL_ERROR;
} else {
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objc+1, newObjv,
command, length, 0);
iPtr->numLevels--;
}
Tcl_DecrRefCount(newObjv[0]);
ckfree((char *) newObjv);
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
}
goto done;
}
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
}
/*
* Call trace procedures if needed.
*/
if ((checkTraces) && (command != NULL)) {
int cmdEpoch = cmdPtr->cmdEpoch;
int newEpoch;
cmdPtr->refCount++;
/*
* If the first set of traces modifies/deletes the command or
* any existing traces, then the set checkTraces to 0 and
* go through this while loop one more time.
*/
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
}
if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& (traceCode == TCL_OK)) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_ENTER_EXEC, objc, objv);
}
newEpoch = cmdPtr->cmdEpoch;
TclCleanupCommand(cmdPtr);
if (cmdEpoch != newEpoch) {
/* The command has been modified in some way */
checkTraces = 0;
continue;
}
}
break;
}
/*
* Finally, invoke the command's Tcl_ObjCmdProc.
*/
cmdPtr->refCount++;
iPtr->cmdCount++;
if ( code == TCL_OK && traceCode == TCL_OK) {
code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
}
if (Tcl_AsyncReady()) {
code = Tcl_AsyncInvoke(interp, code);
}
/*
* Call 'leave' command traces
*/
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
int saveErrFlags = iPtr->flags
& (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) {
traceCode = TclCheckExecutionTraces (interp, command, length,
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (iPtr->tracePtr != NULL && traceCode == TCL_OK) {
traceCode = TclCheckInterpTraces(interp, command, length,
cmdPtr, code, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
if (traceCode == TCL_OK) {
iPtr->flags |= saveErrFlags;
}
}
TclCleanupCommand(cmdPtr);
/*
* If one of the trace invocation resulted in error, then
* change the result code accordingly. Note, that the
* interp->result should already be set correctly by the
|
| ︙ | ︙ | |||
3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 |
*/
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
done:
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalObjv --
| > | 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 |
*/
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
done:
iPtr->varFramePtr = savedVarFramePtr;
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalObjv --
|
| ︙ | ︙ | |||
3184 3185 3186 3187 3188 3189 3190 |
}
cmdString = Tcl_DStringValue(&cmdBuf);
cmdLen = Tcl_DStringLength(&cmdBuf);
break;
}
}
| < < | | < | < | 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 |
}
cmdString = Tcl_DStringValue(&cmdBuf);
cmdLen = Tcl_DStringLength(&cmdBuf);
break;
}
}
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objc, objv, cmdString, cmdLen, flags);
iPtr->numLevels--;
/*
* If we are again at the top level, process any unusual
* return code returned by the evaluated code.
*/
if (iPtr->numLevels == 0) {
|
| ︙ | ︙ | |||
3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 |
if (length < 0) {
length = strlen(command);
}
if (length > 150) {
length = 150;
ellipsis = "...";
}
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sprintf(buffer, "\n while executing\n\"%.*s%s\"",
length, command, ellipsis);
} else {
sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
length, command, ellipsis);
}
Tcl_AddObjErrorInfo(interp, buffer, -1);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
/*
*----------------------------------------------------------------------
*
| > > > > > > > > | | > > > > > > > > > > > > > > > > > | 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 |
if (length < 0) {
length = strlen(command);
}
if (length > 150) {
length = 150;
ellipsis = "...";
}
while ( (command[length] & 0xC0) == 0x80 ) {
/*
* Back up truncation point so that we don't truncate in the
* middle of a multi-byte character (in UTF-8)
*/
length--;
ellipsis = "...";
}
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sprintf(buffer, "\n while executing\n\"%.*s%s\"",
length, command, ellipsis);
} else {
sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
length, command, ellipsis);
}
Tcl_AddObjErrorInfo(interp, buffer, -1);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalTokensStandard, EvalTokensStandard --
*
* Given an array of tokens parsed from a Tcl command (e.g., the
* tokens that make up a word or the index for an array variable)
* this procedure evaluates the tokens and concatenates their
* values to form a single result value.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR. A result or error message is left in
* interp's result.
*
* Side effects:
* Depends on the array of tokens being evaled.
*
* TIP #280 : Keep public API, internally extended API.
*----------------------------------------------------------------------
*/
int
Tcl_EvalTokensStandard(interp, tokenPtr, count)
Tcl_Interp *interp; /* Interpreter in which to lookup
* variables, execute nested commands,
* and report errors. */
Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
* to evaluate and concatenate. */
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
#ifdef TCL_TIP280
return EvalTokensStandard (interp, tokenPtr, count, 1);
}
static int
EvalTokensStandard(interp, tokenPtr, count, line)
Tcl_Interp *interp; /* Interpreter in which to lookup
* variables, execute nested commands,
* and report errors. */
Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
* to evaluate and concatenate. */
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
int line; /* The line the script starts on. */
{
#endif
Tcl_Obj *resultPtr, *indexPtr, *valuePtr;
char buffer[TCL_UTF_MAX];
#ifdef TCL_MEM_DEBUG
# define MAX_VAR_CHARS 5
#else
# define MAX_VAR_CHARS 30
#endif
|
| ︙ | ︙ | |||
3386 3387 3388 3389 3390 3391 3392 | case TCL_TOKEN_BS: length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer); p = buffer; break; | | > > > > > | | > > > > > > > > > > > > > > | 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 |
case TCL_TOKEN_BS:
length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
buffer);
p = buffer;
break;
case TCL_TOKEN_COMMAND: {
Interp *iPtr = (Interp *) interp;
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
#ifndef TCL_TIP280
code = Tcl_EvalEx(interp,
tokenPtr->start+1, tokenPtr->size-2, 0);
#else
/* TIP #280: Transfer line information to nested command */
code = EvalEx(interp,
tokenPtr->start+1, tokenPtr->size-2, 0, line);
#endif
}
iPtr->numLevels--;
if (code != TCL_OK) {
goto done;
}
valuePtr = Tcl_GetObjResult(interp);
break;
}
case TCL_TOKEN_VARIABLE:
if (tokenPtr->numComponents == 1) {
indexPtr = NULL;
index = NULL;
} else {
#ifndef TCL_TIP280
code = Tcl_EvalTokensStandard(interp, tokenPtr+2,
tokenPtr->numComponents - 1);
#else
/* TIP #280: Transfer line information to nested command */
code = EvalTokensStandard(interp, tokenPtr+2,
tokenPtr->numComponents - 1, line);
#endif
if (code != TCL_OK) {
goto done;
}
indexPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(indexPtr);
index = Tcl_GetString(indexPtr);
}
|
| ︙ | ︙ | |||
3481 3482 3483 3484 3485 3486 3487 |
done:
if (resultPtr != NULL) {
Tcl_DecrRefCount(resultPtr);
}
return code;
}
| | < | 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 |
done:
if (resultPtr != NULL) {
Tcl_DecrRefCount(resultPtr);
}
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalTokens --
*
* Given an array of tokens parsed from a Tcl command (e.g., the
* tokens that make up a word or the index for an array variable)
|
| ︙ | ︙ | |||
3538 3539 3540 3541 3542 3543 3544 |
}
}
/*
*----------------------------------------------------------------------
*
| | > > > > > > > > > > > > > > > > > > > > > | > > > > > | 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 |
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalEx, EvalEx --
*
* This procedure evaluates a Tcl script without using the compiler
* or byte-code interpreter. It just parses the script, creates
* values for each word of each command, then calls EvalObjv
* to execute each command.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR. A result or error message is left in
* interp's result.
*
* Side effects:
* Depends on the script.
*
* TIP #280 : Keep public API, internally extended API.
*----------------------------------------------------------------------
*/
int
Tcl_EvalEx(interp, script, numBytes, flags)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
CONST char *script; /* First character of script to evaluate. */
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently
* supported. */
{
#ifdef TCL_TIP280
return EvalEx (interp, script, numBytes, flags, 1);
}
static int
EvalEx(interp, script, numBytes, flags, line)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
CONST char *script; /* First character of script to evaluate. */
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently
* supported. */
int line; /* The line the script starts on. */
{
#endif
Interp *iPtr = (Interp *) interp;
CONST char *p, *next;
Tcl_Parse parse;
#define NUM_STATIC_OBJS 20
Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
Tcl_Token *tokenPtr;
int code = TCL_OK;
int i, commandLength, bytesLeft, nested;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
/*
* The variables below keep track of how much state has been
* allocated while evaluating the script, so that it can be freed
* properly if an error occurs.
*/
int gotParse = 0, objectsUsed = 0;
#ifdef TCL_TIP280
/* TIP #280 Structures for tracking of command locations. */
CmdFrame eeFrame;
#endif
if (numBytes < 0) {
numBytes = strlen(script);
}
Tcl_ResetResult(interp);
savedVarFramePtr = iPtr->varFramePtr;
|
| ︙ | ︙ | |||
3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 |
p = script;
bytesLeft = numBytes;
if (iPtr->evalFlags & TCL_BRACKET_TERM) {
nested = 1;
} else {
nested = 0;
}
iPtr->evalFlags = 0;
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
!= TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
if (nested && parse.term == (script + numBytes)) {
/*
* A nested script can only terminate in ']'. If
* the parsing got terminated at the end of the script,
* there was no closing ']'. Report the syntax error.
*/
code = TCL_ERROR;
goto error;
}
if (parse.numWords > 0) {
/*
* Generate an array of objects for the words of the command.
*/
if (parse.numWords <= NUM_STATIC_OBJS) {
objv = staticObjArray;
} else {
objv = (Tcl_Obj **) ckalloc((unsigned)
(parse.numWords * sizeof (Tcl_Obj *)));
}
for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > | > > | | | | > > | > | | | < | | < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 |
p = script;
bytesLeft = numBytes;
if (iPtr->evalFlags & TCL_BRACKET_TERM) {
nested = 1;
} else {
nested = 0;
}
#ifdef TCL_TIP280
/* TIP #280 Initialize tracking. Do not push on the frame stack yet. */
/*
* We may cont. counting based on a specific context (CTX), or open a new
* context, either for a sourced script, or 'eval'. For sourced files we
* always have a path object, even if nothing was specified in the interp
* itself. That makes code using it simpler as NULL checks can be left
* out. Sourced file without path in the 'scriptFile' is possible during
* Tcl initialization.
*/
if (iPtr->evalFlags & TCL_EVAL_CTX) {
/* Path information comes out of the context. */
eeFrame.type = TCL_LOCATION_SOURCE;
eeFrame.data.eval.path = iPtr->invokeCmdFramePtr->data.eval.path;
Tcl_IncrRefCount (eeFrame.data.eval.path);
} else if (iPtr->evalFlags & TCL_EVAL_FILE) {
/* Set up for a sourced file */
eeFrame.type = TCL_LOCATION_SOURCE;
if (iPtr->scriptFile) {
/* Normalization here, to have the correct pwd. Should have
* negligible impact on performance, as the norm should have been
* done already by the 'source' invoking us, and it caches the
* result
*/
Tcl_Obj* norm = Tcl_FSGetNormalizedPath (interp, iPtr->scriptFile);
if (!norm) {
/* Error message in the interp result */
return TCL_ERROR;
}
eeFrame.data.eval.path = norm;
Tcl_IncrRefCount (eeFrame.data.eval.path);
} else {
eeFrame.data.eval.path = Tcl_NewStringObj ("",-1);
}
} else {
/* Set up for plain eval */
eeFrame.type = TCL_LOCATION_EVAL;
eeFrame.data.eval.path = NULL;
}
eeFrame.level = (iPtr->cmdFramePtr == NULL
? 1
: iPtr->cmdFramePtr->level + 1);
eeFrame.framePtr = iPtr->framePtr;
eeFrame.nextPtr = iPtr->cmdFramePtr;
eeFrame.nline = 0;
eeFrame.line = NULL;
#endif
iPtr->evalFlags = 0;
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
!= TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
if (nested && parse.term == (script + numBytes)) {
/*
* A nested script can only terminate in ']'. If
* the parsing got terminated at the end of the script,
* there was no closing ']'. Report the syntax error.
*/
code = TCL_ERROR;
goto error;
}
#ifdef TCL_TIP280
/*
* TIP #280 Track lines. The parser may have skipped text till it
* found the command we are now at. We have count the lines in this
* block.
*/
TclAdvanceLines (&line, p, parse.commandStart);
#endif
if (parse.numWords > 0) {
#ifdef TCL_TIP280
/*
* TIP #280. Track lines within the words of the current
* command.
*/
int wordLine = line;
CONST char* wordStart = parse.commandStart;
#endif
/*
* Generate an array of objects for the words of the command.
*/
if (parse.numWords <= NUM_STATIC_OBJS) {
objv = staticObjArray;
} else {
objv = (Tcl_Obj **) ckalloc((unsigned)
(parse.numWords * sizeof (Tcl_Obj *)));
}
#ifdef TCL_TIP280
eeFrame.nline = parse.numWords;
eeFrame.line = (int*) ckalloc((unsigned)
(parse.numWords * sizeof (int)));
#endif
for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
objectsUsed < parse.numWords;
objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
#ifndef TCL_TIP280
code = Tcl_EvalTokensStandard(interp, tokenPtr+1,
tokenPtr->numComponents);
#else
/*
* TIP #280. Track lines to current word. Save the
* information on a per-word basis, signaling dynamic words as
* needed. Make the information available to the recursively
* called evaluator as well, including the type of context
* (source vs. eval).
*/
TclAdvanceLines (&wordLine, wordStart, tokenPtr->start);
wordStart = tokenPtr->start;
eeFrame.line [objectsUsed] = (TclWordKnownAtCompileTime (tokenPtr)
? wordLine
: -1);
if (eeFrame.type == TCL_LOCATION_SOURCE) {
iPtr->evalFlags |= TCL_EVAL_FILE;
}
code = EvalTokensStandard(interp, tokenPtr+1,
tokenPtr->numComponents, wordLine);
iPtr->evalFlags = 0;
#endif
if (code == TCL_OK) {
objv[objectsUsed] = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objv[objectsUsed]);
} else {
goto error;
}
}
/*
* Execute the command and free the objects for its words.
*
* TIP #280: Remember the command itself for 'info frame'. We
* shorten the visible command by one char to exclude the
* termination character, if necessary. Here is where we put our
* frame on the stack of frames too. _After_ the nested commands
* have been executed.
*/
#ifdef TCL_TIP280
eeFrame.cmd.str.cmd = parse.commandStart;
eeFrame.cmd.str.len = parse.commandSize;
if (parse.term == parse.commandStart + parse.commandSize - 1) {
eeFrame.cmd.str.len --;
}
iPtr->cmdFramePtr = &eeFrame;
#endif
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objectsUsed, objv,
parse.commandStart, parse.commandSize, 0);
iPtr->numLevels--;
#ifdef TCL_TIP280
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
ckfree ((char*) eeFrame.line);
eeFrame.line = NULL;
eeFrame.nline = 0;
#endif
if (code != TCL_OK) {
goto error;
}
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
objectsUsed = 0;
if (objv != staticObjArray) {
ckfree((char *) objv);
objv = staticObjArray;
}
}
/*
* Advance to the next command in the script.
*
* TIP #280 Track Lines. Now we track how many lines were in the
* executed command.
*/
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
#ifdef TCL_TIP280
TclAdvanceLines (&line, parse.commandStart, p);
#endif
Tcl_FreeParse(&parse);
gotParse = 0;
if (nested && (*parse.term == ']')) {
/*
* We get here in the special case where the TCL_BRACKET_TERM
* flag was set in the interpreter and the latest parsed command
* was terminated by the matching close-bracket we seek.
* Return immediately.
*/
iPtr->termOffset = (p - 1) - script;
iPtr->varFramePtr = savedVarFramePtr;
#ifndef TCL_TIP280
return TCL_OK;
#else
code = TCL_OK;
goto cleanup_return;
#endif
}
} while (bytesLeft > 0);
if (nested) {
/*
* This nested script did not terminate in ']', it is an error.
*/
code = TCL_ERROR;
goto error;
}
iPtr->termOffset = p - script;
iPtr->varFramePtr = savedVarFramePtr;
#ifndef TCL_TIP280
return TCL_OK;
#else
code = TCL_OK;
goto cleanup_return;
#endif
error:
/*
* Generate various pieces of error information, such as the line
* number where the error occurred and information to add to the
* errorInfo variable. Then free resources that had been allocated
* to the command.
*/
if (iPtr->numLevels == 0) {
if (code == TCL_RETURN) {
code = TclUpdateReturnInfo(iPtr);
}
if ((code != TCL_OK) && (code != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, code);
code = TCL_ERROR;
}
}
if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
commandLength = parse.commandSize;
if (parse.term == parse.commandStart + commandLength - 1) {
/*
* The terminator character (such as ; or ]) of the command where
* the error occurred is the last character in the parsed command.
* Reduce the length by one so that the error message doesn't
|
| ︙ | ︙ | |||
3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 |
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
if (!nested) {
iPtr->termOffset = p - script;
return code;
}
/*
* When we are nested (the TCL_BRACKET_TERM flag was set in the
* interpreter), we must find the matching close-bracket to
* end the script we are evaluating.
*
| > > > > | 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 |
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
if (!nested) {
iPtr->termOffset = p - script;
#ifndef TCL_TIP280
return code;
#else
goto cleanup_return;
#endif
}
/*
* When we are nested (the TCL_BRACKET_TERM flag was set in the
* interpreter), we must find the matching close-bracket to
* end the script we are evaluating.
*
|
| ︙ | ︙ | |||
3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 |
*/
if (next == NULL) {
iPtr->termOffset = (parse.commandStart - 1) - script;
} else {
iPtr->termOffset = (next - 1) - script;
}
return code;
}
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
next = parse.commandStart;
Tcl_FreeParse(&parse);
}
| > > > > | 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 |
*/
if (next == NULL) {
iPtr->termOffset = (parse.commandStart - 1) - script;
} else {
iPtr->termOffset = (next - 1) - script;
}
#ifndef TCL_TIP280
return code;
#else
goto cleanup_return;
#endif
}
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
next = parse.commandStart;
Tcl_FreeParse(&parse);
}
|
| ︙ | ︙ | |||
3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 |
/*
* There was no close-bracket. Syntax error.
*/
iPtr->termOffset = parse.term - script;
Tcl_SetObjResult(interp,
Tcl_NewStringObj("missing close-bracket", -1));
return TCL_ERROR;
} else if (*parse.term != ']') {
/*
* There was no close-bracket. Syntax error.
*/
iPtr->termOffset = (parse.term + 1) - script;
Tcl_SetObjResult(interp,
Tcl_NewStringObj("missing close-bracket", -1));
return TCL_ERROR;
} else {
/*
* parse.term points to the close-bracket.
*/
iPtr->termOffset = parse.term - script;
}
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Eval --
*
* Execute a Tcl command in a string. This procedure executes the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 |
/*
* There was no close-bracket. Syntax error.
*/
iPtr->termOffset = parse.term - script;
Tcl_SetObjResult(interp,
Tcl_NewStringObj("missing close-bracket", -1));
#ifndef TCL_TIP280
return TCL_ERROR;
#else
code = TCL_ERROR;
goto cleanup_return;
#endif
} else if (*parse.term != ']') {
/*
* There was no close-bracket. Syntax error.
*/
iPtr->termOffset = (parse.term + 1) - script;
Tcl_SetObjResult(interp,
Tcl_NewStringObj("missing close-bracket", -1));
#ifndef TCL_TIP280
return TCL_ERROR;
#else
code = TCL_ERROR;
goto cleanup_return;
#endif
} else {
/*
* parse.term points to the close-bracket.
*/
iPtr->termOffset = parse.term - script;
}
#ifdef TCL_TIP280
cleanup_return:
/* TIP #280. Release the local CmdFrame, and its contents. */
if (eeFrame.line != NULL) {
ckfree ((char*) eeFrame.line);
}
if (eeFrame.type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (eeFrame.data.eval.path);
}
#endif
return code;
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
* TclAdvanceLines --
*
* This procedure is a helper which counts the number of lines
* in a block of text and advances an external counter.
*
* Results:
* None.
*
* Side effects:
* The specified counter is advanced per the number of lines found.
*
* TIP #280
*----------------------------------------------------------------------
*/
void
TclAdvanceLines (line,start,end)
int* line;
CONST char* start;
CONST char* end;
{
CONST char* p;
for (p = start; p < end; p++) {
if (*p == '\n') {
(*line) ++;
}
}
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_Eval --
*
* Execute a Tcl command in a string. This procedure executes the
|
| ︙ | ︙ | |||
3912 3913 3914 3915 3916 3917 3918 |
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
/*
*----------------------------------------------------------------------
*
| | > > > > > > > > > > > > > > > > > > > > > | 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 |
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalObjEx, TclEvalObjEx --
*
* Execute Tcl commands stored in a Tcl object. These commands are
* compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT
* is specified.
*
* Results:
* The return value is one of the return codes defined in tcl.h
* (such as TCL_OK), and the interpreter's result contains a value
* to supplement the return code.
*
* Side effects:
* The object is converted, if necessary, to a ByteCode object that
* holds the bytecode instructions for the commands. Executing the
* commands will almost certainly have side effects that depend
* on those commands.
*
* Just as in Tcl_Eval, interp->termOffset is set to the offset of the
* last character executed in the objPtr's string.
*
* TIP #280 : Keep public API, internally extended API.
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjEx(interp, objPtr, flags)
Tcl_Interp *interp; /* Token for command interpreter
* (returned by a previous call to
* Tcl_CreateInterp). */
register Tcl_Obj *objPtr; /* Pointer to object containing
* commands to execute. */
int flags; /* Collection of OR-ed bits that
* control the evaluation of the
* script. Supported values are
* TCL_EVAL_GLOBAL and
* TCL_EVAL_DIRECT. */
{
#ifdef TCL_TIP280
return TclEvalObjEx (interp, objPtr, flags, NULL, 0);
}
int
TclEvalObjEx(interp, objPtr, flags, invoker, word)
Tcl_Interp *interp; /* Token for command interpreter
* (returned by a previous call to
* Tcl_CreateInterp). */
register Tcl_Obj *objPtr; /* Pointer to object containing
* commands to execute. */
int flags; /* Collection of OR-ed bits that
* control the evaluation of the
* script. Supported values are
* TCL_EVAL_GLOBAL and
* TCL_EVAL_DIRECT. */
CONST CmdFrame* invoker; /* Frame of the command doing the eval */
int word; /* Index of the word which is in objPtr */
{
#endif
register Interp *iPtr = (Interp *) interp;
char *script;
int numSrcBytes;
int result;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
|
| ︙ | ︙ | |||
3978 3979 3980 3981 3982 3983 3984 |
* (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
*/
if (!(iPtr->flags & USE_EVAL_DIRECT) &&
(objPtr->typePtr == &tclListType) && /* is a list... */
(objPtr->bytes == NULL) /* ...without a string rep */) {
register List *listRepPtr =
(List *) objPtr->internalRep.twoPtrValue.ptr1;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 |
* (ensure we go into the TCL_EVAL_DIRECT path, avoiding opt)
*/
if (!(iPtr->flags & USE_EVAL_DIRECT) &&
(objPtr->typePtr == &tclListType) && /* is a list... */
(objPtr->bytes == NULL) /* ...without a string rep */) {
register List *listRepPtr =
(List *) objPtr->internalRep.twoPtrValue.ptr1;
int i, objc = listRepPtr->elemCount;
#define TEOE_PREALLOC 10
Tcl_Obj *staticObjv[TEOE_PREALLOC], **objv = staticObjv;
#ifdef TCL_TIP280
/* TIP #280 Structures for tracking lines.
* As we know that this is dynamic execution we ignore the
* invoker, even if known.
*/
int line;
CmdFrame eoFrame;
eoFrame.type = TCL_LOCATION_EVAL_LIST;
eoFrame.level = (iPtr->cmdFramePtr == NULL ?
1 :
iPtr->cmdFramePtr->level + 1);
eoFrame.framePtr = iPtr->framePtr;
eoFrame.nextPtr = iPtr->cmdFramePtr;
eoFrame.nline = objc;
eoFrame.line = (int*) ckalloc (objc * sizeof (int));
/* NOTE: Getting the string rep of the list to eval to fill the
* command information required by 'info frame' implies that
* further calls for the same list would not be optimized, as it
* would not be 'pure' anymore. It would also be a waste of time
* as most of the time this information is not needed at all. What
* we do instead is to keep the list obj itself around and have
* 'info frame' sort it out.
*/
eoFrame.cmd.listPtr = objPtr;
Tcl_IncrRefCount (eoFrame.cmd.listPtr);
eoFrame.data.eval.path = NULL;
#endif
if (objc > TEOE_PREALLOC) {
objv = (Tcl_Obj **) ckalloc(objc*sizeof(Tcl_Obj *));
}
#undef TEOE_PREALLOC
/*
* Copy the list elements here, to avoid a segfault if
* objPtr loses its List internal rep [Bug 1119369].
*
* TIP #280 Computes all the line numbers for the
* words in the command.
*/
#ifdef TCL_TIP280
line = 1;
#endif
for (i=0; i < objc; i++) {
objv[i] = listRepPtr->elements[i];
Tcl_IncrRefCount(objv[i]);
#ifdef TCL_TIP280
eoFrame.line [i] = line;
{
char* w = Tcl_GetString (objv [i]);
TclAdvanceLines (&line, w, w+ strlen(w));
}
#endif
}
#ifdef TCL_TIP280
iPtr->cmdFramePtr = &eoFrame;
#endif
result = Tcl_EvalObjv(interp, objc, objv, flags);
#ifdef TCL_TIP280
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
Tcl_DecrRefCount (eoFrame.cmd.listPtr);
#endif
for (i=0; i < objc; i++) {
TclDecrRefCount(objv[i]);
}
if (objv != staticObjv) {
ckfree((char *) objv);
}
#ifdef TCL_TIP280
ckfree ((char*) eoFrame.line);
eoFrame.line = NULL;
eoFrame.nline = 0;
#endif
} else {
#ifndef TCL_TIP280
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
#else
/*
* TIP #280. Propagate context as much as we can. Especially if
* the script to evaluate is a single literal it makes sense to
* look if our context is one with absolute line numbers we can
* then track into the literal itself too.
*
* See also tclCompile.c, TclInitCompileEnv, for the equivalent
* code in the bytecode compiler.
*/
if (invoker == NULL) {
/* No context, force opening of our own */
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
} else {
/* We have an invoker, describing the command asking for the
* evaluation of a subordinate script. This script may
* originate in a literal word, or from a variable, etc. Using
* the line array we now check if we have good line
* information for the relevant word. The type of context is
* relevant as well. In a non-'source' context we don't have
* to try tracking lines.
*
* First see if the word exists and is a literal. If not we go
* through the easy dynamic branch. No need to perform more
* complex invokations.
*/
if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
/* Dynamic script, or dynamic context, force our own
* context */
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
} else {
/* Try to get an absolute context for the evaluation
*/
CmdFrame ctx = *invoker;
int pc = 0;
if (invoker->type == TCL_LOCATION_BC) {
/* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc (&ctx);
pc = 1;
}
if (ctx.type == TCL_LOCATION_SOURCE) {
/* Absolute context to reuse. */
iPtr->invokeCmdFramePtr = &ctx;
iPtr->evalFlags |= TCL_EVAL_CTX;
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = EvalEx(interp, script, numSrcBytes, flags, ctx.line [word]);
if (pc) {
/* Death of SrcInfo reference */
Tcl_DecrRefCount (ctx.data.eval.path);
}
} else {
/* Dynamic context or script, easier to make our own as
* well */
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
result = Tcl_EvalEx(interp, script, numSrcBytes, flags);
}
}
}
#endif
}
} else {
/*
* Let the compiler/engine subsystem do the evaluation.
*
* TIP #280 The invoker provides us with the context for the
* script. We transfer this to the byte code compiler.
*/
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
}
#ifndef TCL_TIP280
result = TclCompEvalObj(interp, objPtr);
#else
result = TclCompEvalObj(interp, objPtr, invoker, word);
#endif
/*
* If we are again at the top level, process any unusual
* return code returned by the evaluated code.
*/
if (iPtr->numLevels == 0) {
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
}
if ((result != TCL_OK) && (result != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
/*
* If an error was created here, record information about
* what was being executed when the error occurred. Remove
* the extra \n added by tclMain.c in the command sent to
* Tcl_LogCommandInfo [Bug 833150].
*/
if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, --numSrcBytes);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
}
}
iPtr->evalFlags = 0;
iPtr->varFramePtr = savedVarFramePtr;
}
|
| ︙ | ︙ | |||
4112 4113 4114 4115 4116 4117 4118 |
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store an integer based on the expression result.
*/
| | > > > > > > > > > > > > > > > > > > | 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 |
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store an integer based on the expression result.
*/
if (resultPtr->typePtr == &tclIntType) {
*ptr = resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (long) resultPtr->internalRep.doubleValue;
} else if (resultPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
/*
* See Tcl_GetIntFromObj for conversion comments.
*/
Tcl_WideInt w = resultPtr->internalRep.wideValue;
if ((w >= -(Tcl_WideInt)(ULONG_MAX))
&& (w <= (Tcl_WideInt)(ULONG_MAX))) {
*ptr = Tcl_WideAsLong(w);
} else {
Tcl_SetResult(interp,
"integer value too large to represent as non-long integer",
TCL_STATIC);
result = TCL_ERROR;
}
#else
*ptr = resultPtr->internalRep.longValue;
#endif
} else {
Tcl_SetResult(interp,
"expression didn't have numeric value", TCL_STATIC);
result = TCL_ERROR;
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
} else {
|
| ︙ | ︙ | |||
4163 4164 4165 4166 4167 4168 4169 |
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store a double based on the expression result.
*/
| | > > > > > > > > > > > > > > > > > > | 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 |
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store a double based on the expression result.
*/
if (resultPtr->typePtr == &tclIntType) {
*ptr = (double) resultPtr->internalRep.longValue;
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = resultPtr->internalRep.doubleValue;
} else if (resultPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
/*
* See Tcl_GetIntFromObj for conversion comments.
*/
Tcl_WideInt w = resultPtr->internalRep.wideValue;
if ((w >= -(Tcl_WideInt)(ULONG_MAX))
&& (w <= (Tcl_WideInt)(ULONG_MAX))) {
*ptr = (double) Tcl_WideAsLong(w);
} else {
Tcl_SetResult(interp,
"integer value too large to represent as non-long integer",
TCL_STATIC);
result = TCL_ERROR;
}
#else
*ptr = (double) resultPtr->internalRep.longValue;
#endif
} else {
Tcl_SetResult(interp,
"expression didn't have numeric value", TCL_STATIC);
result = TCL_ERROR;
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
} else {
|
| ︙ | ︙ | |||
4214 4215 4216 4217 4218 4219 4220 |
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store a boolean based on the expression result.
*/
| | > > > > > > | 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 |
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
* Store a boolean based on the expression result.
*/
if (resultPtr->typePtr == &tclIntType) {
*ptr = (resultPtr->internalRep.longValue != 0);
} else if (resultPtr->typePtr == &tclDoubleType) {
*ptr = (resultPtr->internalRep.doubleValue != 0.0);
} else if (resultPtr->typePtr == &tclWideIntType) {
#ifndef TCL_WIDE_INT_IS_LONG
*ptr = (resultPtr->internalRep.wideValue != 0);
#else
*ptr = (resultPtr->internalRep.longValue != 0);
#endif
} else {
result = Tcl_GetBooleanFromObj(interp, resultPtr, ptr);
}
Tcl_DecrRefCount(resultPtr); /* discard the result object */
}
if (result != TCL_OK) {
/*
|
| ︙ | ︙ | |||
4563 4564 4565 4566 4567 4568 4569 |
char *cmdName; /* Name of the command from objv[0]. */
register Tcl_HashEntry *hPtr;
Tcl_Command cmd;
Command *cmdPtr;
int localObjc; /* Used to invoke "unknown" if the */
Tcl_Obj **localObjv = NULL; /* command is not found. */
register int i;
| | < | 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 |
char *cmdName; /* Name of the command from objv[0]. */
register Tcl_HashEntry *hPtr;
Tcl_Command cmd;
Command *cmdPtr;
int localObjc; /* Used to invoke "unknown" if the */
Tcl_Obj **localObjv = NULL; /* command is not found. */
register int i;
int result;
if (interp == (Tcl_Interp *) NULL) {
return TCL_ERROR;
}
if ((objc < 1) || (objv == (Tcl_Obj **) NULL)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
| ︙ | ︙ | |||
4657 4658 4659 4660 4661 4662 4663 |
* If an error occurred, record information about what was being
* executed when the error occurred.
*/
if ((result == TCL_ERROR)
&& ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
&& ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
| | < | | > > > > > | | > > > > | < > | > | | | | > > | | > | | | | 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 |
* If an error occurred, record information about what was being
* executed when the error occurred.
*/
if ((result == TCL_ERROR)
&& ((flags & TCL_INVOKE_NO_TRACEBACK) == 0)
&& ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) {
Tcl_Obj *msg;
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
msg = Tcl_NewStringObj("\n while invoking\n\"", -1);
} else {
msg = Tcl_NewStringObj("\n invoked from within\n\"", -1);
}
Tcl_IncrRefCount(msg);
for (i = 0; i < objc; i++) {
CONST char *bytes;
int length;
Tcl_AppendObjToObj(msg, objv[i]);
bytes = Tcl_GetStringFromObj(msg, &length);
if (length > 100) {
/*
* Back up truncation point so that we don't truncate
* in the middle of a multi-byte character.
*/
length = 100;
while ( (bytes[length] & 0xC0) == 0x80 ) {
length--;
}
Tcl_SetObjLength(msg, length);
Tcl_AppendToObj(msg, "...", -1);
break;
}
if (i != (objc - 1)) {
Tcl_AppendToObj(msg, " ", -1);
}
}
Tcl_AppendToObj(msg, "\"", -1);
Tcl_AddObjErrorInfo(interp, Tcl_GetString(msg), -1);
Tcl_DecrRefCount(msg);
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
/*
* Free any locally allocated storage used to call "unknown".
*/
|
| ︙ | ︙ | |||
5049 5050 5051 5052 5053 5054 5055 |
void
Tcl_DeleteTrace(interp, trace)
Tcl_Interp *interp; /* Interpreter that contains trace. */
Tcl_Trace trace; /* Token for trace (returned previously by
* Tcl_CreateTrace). */
{
Interp *iPtr = (Interp *) interp;
| | > > > > > > > > > > > > > > > > > > > > | 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 |
void
Tcl_DeleteTrace(interp, trace)
Tcl_Interp *interp; /* Interpreter that contains trace. */
Tcl_Trace trace; /* Token for trace (returned previously by
* Tcl_CreateTrace). */
{
Interp *iPtr = (Interp *) interp;
Trace *prevPtr, *tracePtr = (Trace *) trace;
register Trace **tracePtr2 = &(iPtr->tracePtr);
ActiveInterpTrace *activePtr;
/*
* Locate the trace entry in the interpreter's trace list,
* and remove it from the list.
*/
prevPtr = NULL;
while ((*tracePtr2) != NULL && (*tracePtr2) != tracePtr) {
prevPtr = *tracePtr2;
tracePtr2 = &((*tracePtr2)->nextPtr);
}
if (*tracePtr2 == NULL) {
return;
}
(*tracePtr2) = (*tracePtr2)->nextPtr;
/*
* The code below makes it possible to delete traces while traces
* are active: it makes sure that the deleted trace won't be
* processed by TclCheckInterpTraces.
*/
for (activePtr = iPtr->activeInterpTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
if (activePtr->reverseScan) {
activePtr->nextTracePtr = prevPtr;
} else {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
}
/*
* If the trace forbids bytecode compilation, change the interpreter's
* state. If bytecode compilation is now permitted, flag the fact and
* advance the compilation epoch so that procs will be recompiled to
* take advantage of it.
*/
|
| ︙ | ︙ | |||
5157 5158 5159 5160 5161 5162 5163 |
CONST char *message; /* Points to the first byte of an array of
* bytes of the message. */
int length; /* The number of bytes in the message.
* If < 0, then append all bytes up to a
* NULL byte. */
{
register Interp *iPtr = (Interp *) interp;
| | > > | > > > | > | | | | | 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 |
CONST char *message; /* Points to the first byte of an array of
* bytes of the message. */
int length; /* The number of bytes in the message.
* If < 0, then append all bytes up to a
* NULL byte. */
{
register Interp *iPtr = (Interp *) interp;
Tcl_Obj *objPtr;
/*
* If we are just starting to log an error, errorInfo is initialized
* from the error message in the interpreter's result.
*/
if (!(iPtr->flags & ERR_IN_PROGRESS)) { /* just starting to log error */
iPtr->flags |= ERR_IN_PROGRESS;
if (iPtr->result[0] == 0) {
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
iPtr->objResultPtr, TCL_GLOBAL_ONLY);
} else { /* use the string result */
objPtr = Tcl_NewStringObj(interp->result, -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
}
/*
* If the errorCode variable wasn't set by the code that generated
* the error, set it to "NONE".
*/
if (!(iPtr->flags & ERROR_CODE_SET)) {
objPtr = Tcl_NewStringObj("NONE", -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
}
}
/*
* Now append "message" to the end of errorInfo.
*/
if (length != 0) {
objPtr = Tcl_NewStringObj(message, length);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
objPtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
Tcl_DecrRefCount(objPtr); /* free msg object appended above */
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_VarEvalVA --
|
| ︙ | ︙ | |||
5416 5417 5418 5419 5420 5421 5422 |
if (patchLevelV != NULL) {
*patchLevelV = TCL_RELEASE_SERIAL;
}
if (type != NULL) {
*type = TCL_RELEASE_LEVEL;
}
}
| | > > > > > > > > | 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 |
if (patchLevelV != NULL) {
*patchLevelV = TCL_RELEASE_SERIAL;
}
if (type != NULL) {
*type = TCL_RELEASE_LEVEL;
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclBinary.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * * Copyright (c) 1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * * Copyright (c) 1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclBinary.c,v 1.13.2.4 2005/10/23 22:01:29 msofer Exp $ */ #include "tclInt.h" #include "tclPort.h" #include <math.h> /* |
| ︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | * Prototypes for local procedures defined in this file: */ static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr)); static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, char *cmdPtr, int *countPtr)); static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type, Tcl_HashTable **numberCachePtr)); static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr)); | > > | > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | * Prototypes for local procedures defined in this file: */ static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr)); static void CopyNumber _ANSI_ARGS_((CONST VOID *from, VOID *to, unsigned int length)); static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, char *cmdPtr, int *countPtr)); static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type, Tcl_HashTable **numberCachePtr)); static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr)); static void DeleteScanNumberCache _ANSI_ARGS_(( Tcl_HashTable *numberCachePtr)); /* * The following object type represents an array of bytes. An array of * bytes is not equivalent to an internationalized string. Conceptually, a * string is an array of 16-bit quantities organized as a sequence of properly * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities. * Accessor functions are provided to convert a ByteArray to a String or a |
| ︙ | ︙ | |||
747 748 749 750 751 752 753 |
} else {
offset = count;
}
break;
}
default: {
errorString = str;
| | | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
} else {
offset = count;
}
break;
}
default: {
errorString = str;
goto badField;
}
}
}
if (offset > length) {
length = offset;
}
if (length == 0) {
|
| ︙ | ︙ | |||
1046 1047 1048 1049 1050 1051 1052 |
}
switch (cmd) {
case 'a':
case 'A': {
unsigned char *src;
if (arg >= objc) {
| | < < | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 |
}
switch (cmd) {
case 'a':
case 'A': {
unsigned char *src;
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
count = length - offset;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
|
| ︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 |
if (src[size-1] != '\0' && src[size-1] != ' ') {
break;
}
size--;
}
}
valuePtr = Tcl_NewByteArrayObj(src, size);
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
| > > | < < < | < < | 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 |
if (src[size-1] != '\0' && src[size-1] != ' ') {
break;
}
size--;
}
}
valuePtr = Tcl_NewByteArrayObj(src, size);
Tcl_IncrRefCount(valuePtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(valuePtr);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
offset += count;
break;
}
case 'b':
case 'B': {
unsigned char *src;
char *dest;
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
count = (length - offset) * 8;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
|
| ︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 |
value <<= 1;
} else {
value = *src++;
}
*dest++ = (char) ((value & 0x80) ? '1' : '0');
}
}
| | > > | < < < | < < | 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 |
value <<= 1;
} else {
value = *src++;
}
*dest++ = (char) ((value & 0x80) ? '1' : '0');
}
}
Tcl_IncrRefCount(valuePtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(valuePtr);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
offset += (count + 7 ) / 8;
break;
}
case 'h':
case 'H': {
char *dest;
unsigned char *src;
int i;
static char hexdigit[] = "0123456789abcdef";
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_ALL) {
count = (length - offset)*2;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
|
| ︙ | ︙ | |||
1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 |
} else {
value = *src++;
}
*dest++ = hexdigit[(value >> 4) & 0xf];
}
}
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
| > > | < < < | 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
} else {
value = *src++;
}
*dest++ = hexdigit[(value >> 4) & 0xf];
}
}
Tcl_IncrRefCount(valuePtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(valuePtr);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
offset += (count + 1) / 2;
break;
}
case 'c': {
size = 1;
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 |
unsigned char *src;
size = sizeof(double);
/* fall through */
scanNumber:
if (arg >= objc) {
| | < < | 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 |
unsigned char *src;
size = sizeof(double);
/* fall through */
scanNumber:
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
if ((length - offset) < size) {
goto done;
}
valuePtr = ScanNumber(buffer+offset, cmd,
|
| ︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 |
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr,
elementPtr);
}
offset += count*size;
}
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
| > > | < < < | 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 |
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr,
elementPtr);
}
offset += count*size;
}
Tcl_IncrRefCount(valuePtr);
resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(valuePtr);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
break;
}
case 'x': {
if (count == BINARY_NOCOUNT) {
count = 1;
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 |
} else {
offset -= count;
}
break;
}
case '@': {
if (count == BINARY_NOCOUNT) {
| | < < | < < | | < < | > | 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 |
} else {
offset -= count;
}
break;
}
case '@': {
if (count == BINARY_NOCOUNT) {
DeleteScanNumberCache(numberCachePtr);
goto badCount;
}
if ((count == BINARY_ALL) || (count > length)) {
offset = length;
} else {
offset = count;
}
break;
}
default: {
DeleteScanNumberCache(numberCachePtr);
errorString = str;
goto badField;
}
}
}
/*
* Set the result to the last position of the cursor.
*/
done:
Tcl_ResetResult(interp);
Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
DeleteScanNumberCache(numberCachePtr);
break;
}
}
return TCL_OK;
badValue:
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
" string but got \"", errorValue, "\" instead", NULL);
return TCL_ERROR;
badCount:
errorString = "missing count for \"@\" field specifier";
goto error;
badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
badField:
{
Tcl_UniChar ch;
char buf[TCL_UTF_MAX + 1];
Tcl_UtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1477 1478 1479 1480 1481 1482 1483 |
* memcpy to avoid alignment issues.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
return TCL_ERROR;
}
if (type == 'd') {
| > > > | > | 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 |
* memcpy to avoid alignment issues.
*/
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
return TCL_ERROR;
}
if (type == 'd') {
/*
* Can't just memcpy() here. [Bug 1116542]
*/
CopyNumber(&dvalue, *cursorPtr, sizeof(double));
*cursorPtr += sizeof(double);
} else {
float fvalue;
/*
* Because some compilers will generate floating point exceptions
* on an overflow cast (e.g. Borland), we restrict the values
|
| ︙ | ︙ | |||
1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 |
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) value;
}
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* ScanNumber --
*
* This routine is called by Tcl_BinaryObjCmd to scan a number
| > > > > > > > > > > | 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 |
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) value;
}
return TCL_OK;
}
}
/* Ugly workaround for old and broken compiler! */
static void
CopyNumber(from, to, length)
CONST VOID *from;
VOID *to;
unsigned int length;
{
memcpy(to, from, length);
}
/*
*----------------------------------------------------------------------
*
* ScanNumber --
*
* This routine is called by Tcl_BinaryObjCmd to scan a number
|
| ︙ | ︙ | |||
1663 1664 1665 1666 1667 1668 1669 | * a LOT of varied binary data in a single call! * Bail out by switching back to the old behaviour * for the rest of the scan. * * Note that anyone just using the 'c' conversion * (for bytes) cannot trigger this. */ | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 |
* a LOT of varied binary data in a single call!
* Bail out by switching back to the old behaviour
* for the rest of the scan.
*
* Note that anyone just using the 'c' conversion
* (for bytes) cannot trigger this.
*/
DeleteScanNumberCache(tablePtr);
*numberCachePtrPtr = NULL;
return Tcl_NewLongObj(value);
} else {
register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, (ClientData) objPtr);
return objPtr;
}
}
/*
* Do not cache wide values; they are already too large to
* use as keys.
*/
case 'w':
uwvalue = ((Tcl_WideUInt) buffer[0])
| (((Tcl_WideUInt) buffer[1]) << 8)
| (((Tcl_WideUInt) buffer[2]) << 16)
| (((Tcl_WideUInt) buffer[3]) << 24)
| (((Tcl_WideUInt) buffer[4]) << 32)
| (((Tcl_WideUInt) buffer[5]) << 40)
| (((Tcl_WideUInt) buffer[6]) << 48)
| (((Tcl_WideUInt) buffer[7]) << 56);
return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
case 'W':
uwvalue = ((Tcl_WideUInt) buffer[7])
| (((Tcl_WideUInt) buffer[6]) << 8)
| (((Tcl_WideUInt) buffer[5]) << 16)
| (((Tcl_WideUInt) buffer[4]) << 24)
| (((Tcl_WideUInt) buffer[3]) << 32)
| (((Tcl_WideUInt) buffer[2]) << 40)
| (((Tcl_WideUInt) buffer[1]) << 48)
| (((Tcl_WideUInt) buffer[0]) << 56);
return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
/*
* Do not cache double values; they are already too large
* to use as keys and the values stored are utterly
* incompatible too.
*/
case 'f': {
float fvalue;
memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
return Tcl_NewDoubleObj(fvalue);
}
case 'd': {
double dvalue;
memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
return Tcl_NewDoubleObj(dvalue);
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* DeleteScanNumberCache --
*
* Deletes the hash table acting as a scan number cache.
*
* Results:
* None
*
* Side effects:
* Decrements the reference counts of the objects in the cache.
*
*----------------------------------------------------------------------
*/
static void
DeleteScanNumberCache(numberCachePtr)
Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or
* NULL (when the cache has already
* been deleted due to overflow.) */
{
Tcl_HashEntry *hEntry;
Tcl_HashSearch search;
if (numberCachePtr == NULL) {
return;
}
hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
while (hEntry != NULL) {
register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);
if (value != NULL) {
Tcl_DecrRefCount(value);
}
hEntry = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(numberCachePtr);
}
|
Changes to generic/tclClock.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclClock.c -- * * Contains the time and date related commands. This code * is derived from the time and date facilities of TclX, * by Mark Diekhans and Karl Lehenbauer. * * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | /* * tclClock.c -- * * Contains the time and date related commands. This code * is derived from the time and date facilities of TclX, * by Mark Diekhans and Karl Lehenbauer. * * Copyright 1991-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclClock.c,v 1.20.2.3 2007/04/21 22:42:49 kennykb Exp $ */ #include "tcl.h" #include "tclInt.h" #include "tclPort.h" /* * The date parsing stuff uses lexx and has tons o statics. */ TCL_DECLARE_MUTEX(clockMutex) /* * Function prototypes for local procedures in this file: */ static int FormatClock _ANSI_ARGS_((Tcl_Interp *interp, Tcl_WideInt clockVal, int useGMT, char *format)); /* *------------------------------------------------------------------------- * * Tcl_ClockObjCmd -- * |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
{
Tcl_Obj *resultPtr;
int index;
Tcl_Obj *CONST *objPtr;
int useGMT = 0;
char *format = "%a %b %d %X %Z %Y";
int dummy;
| | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
{
Tcl_Obj *resultPtr;
int index;
Tcl_Obj *CONST *objPtr;
int useGMT = 0;
char *format = "%a %b %d %X %Z %Y";
int dummy;
Tcl_WideInt baseClock, clockVal;
long zone;
Tcl_Obj *baseObjPtr = NULL;
char *scanStr;
int n;
static CONST char *switches[] =
{"clicks", "format", "scan", "seconds", (char *) NULL};
|
| ︙ | ︙ | |||
124 125 126 127 128 129 130 |
if ((objc < 3) || (objc > 7)) {
wrongFmtArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"clockval ?-format string? ?-gmt boolean?");
return TCL_ERROR;
}
| | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
if ((objc < 3) || (objc > 7)) {
wrongFmtArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"clockval ?-format string? ?-gmt boolean?");
return TCL_ERROR;
}
if (Tcl_GetWideIntFromObj(interp, objv[2], &clockVal)
!= TCL_OK) {
return TCL_ERROR;
}
objPtr = objv+3;
objc -= 3;
while (objc > 1) {
|
| ︙ | ︙ | |||
153 154 155 156 157 158 159 |
}
objPtr += 2;
objc -= 2;
}
if (objc != 0) {
goto wrongFmtArgs;
}
| | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
}
objPtr += 2;
objc -= 2;
}
if (objc != 0) {
goto wrongFmtArgs;
}
return FormatClock(interp, clockVal, useGMT,
format);
case COMMAND_SCAN: /* scan */
if ((objc < 3) || (objc > 7)) {
wrongScanArgs:
Tcl_WrongNumArgs(interp, 2, objv,
"dateString ?-base clockValue? ?-gmt boolean?");
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
objc -= 2;
}
if (objc != 0) {
goto wrongScanArgs;
}
if (baseObjPtr != NULL) {
| | | | | | | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
objc -= 2;
}
if (objc != 0) {
goto wrongScanArgs;
}
if (baseObjPtr != NULL) {
if (Tcl_GetWideIntFromObj(interp, baseObjPtr,
&baseClock) != TCL_OK) {
return TCL_ERROR;
}
} else {
baseClock = TclpGetSeconds();
}
if (useGMT) {
zone = -50000; /* Force GMT */
} else {
zone = TclpGetTimeZone(baseClock);
}
scanStr = Tcl_GetStringFromObj(objv[2], &dummy);
Tcl_MutexLock(&clockMutex);
if (TclGetDate(scanStr, baseClock, zone,
&clockVal) < 0) {
Tcl_MutexUnlock(&clockMutex);
Tcl_AppendStringsToObj(resultPtr,
"unable to convert date-time string \"",
scanStr, "\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_MutexUnlock(&clockMutex);
Tcl_SetWideIntObj(resultPtr, clockVal);
return TCL_OK;
case COMMAND_SECONDS: /* seconds */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
*
*-----------------------------------------------------------------------------
*/
static int
FormatClock(interp, clockVal, useGMT, format)
Tcl_Interp *interp; /* Current interpreter. */
| | | | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
*
*-----------------------------------------------------------------------------
*/
static int
FormatClock(interp, clockVal, useGMT, format)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_WideInt clockVal; /* Time in seconds. */
int useGMT; /* Boolean */
char *format; /* Format string */
{
struct tm *timeDataPtr;
Tcl_DString buffer, uniBuffer;
int bufSize;
char *p;
int result;
time_t tclockVal;
#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
TIMEZONE_t savedTimeZone = 0; /* lint. */
char *savedTZEnv = NULL; /* lint. */
#endif
#ifdef HAVE_TZSET
/*
* Some systems forgot to call tzset in localtime, make sure its done.
*/
static int calledTzset = 0;
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
if (varValue != NULL) {
savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue);
} else {
savedTZEnv = NULL;
}
| | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
varValue = Tcl_GetVar2(interp, "env", "TZ", TCL_GLOBAL_ONLY);
if (varValue != NULL) {
savedTZEnv = strcpy(ckalloc(strlen(varValue) + 1), varValue);
} else {
savedTZEnv = NULL;
}
Tcl_SetVar2(interp, "env", "TZ", "GMT0", TCL_GLOBAL_ONLY);
savedTimeZone = timezone;
timezone = 0;
tzset();
}
#endif
tclockVal = (time_t) clockVal;
timeDataPtr = TclpGetDate((TclpTime_t) &tclockVal, useGMT);
/*
* Make a guess at the upper limit on the substituted string size
* based on the number of percents in the string.
*/
|
| ︙ | ︙ |
Changes to generic/tclCmdAH.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclCmdAH.c -- * * This file contains the top-level command routines for most of * the Tcl built-in commands whose names begin with the letters * A to H. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclCmdAH.c -- * * This file contains the top-level command routines for most of * the Tcl built-in commands whose names begin with the letters * A to H. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCmdAH.c,v 1.27.2.16 2006/11/28 22:20:00 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclPort.h" #include <locale.h> /* |
| ︙ | ︙ | |||
231 232 233 234 235 236 237 238 239 240 241 242 243 |
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *varNamePtr = NULL;
int result;
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
return TCL_ERROR;
}
| > > > < < < < < < > > > > > | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 |
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *varNamePtr = NULL;
int result;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?varName?");
return TCL_ERROR;
}
if (objc == 3) {
varNamePtr = objv[2];
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[1], 0);
#else
/* TIP #280. Make invoking context available to caught script */
result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
#endif
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
Tcl_GetObjResult(interp), 0) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"couldn't save command result in variable", -1);
|
| ︙ | ︙ | |||
442 443 444 445 446 447 448 |
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case ENC_CONVERTTO:
case ENC_CONVERTFROM: {
| < | > | > > < < < < < | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case ENC_CONVERTTO:
case ENC_CONVERTFROM: {
Tcl_Obj *data;
if (objc == 3) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[2];
} else if (objc == 4) {
if (TclGetEncodingFromObj(interp, objv[2], &encoding)
!= TCL_OK) {
return TCL_ERROR;
}
data = objv[3];
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
return TCL_ERROR;
}
if ((enum options) index == ENC_CONVERTFROM) {
/*
* Treat the string as binary data.
*/
string = (char *) Tcl_GetByteArrayFromObj(data, &length);
Tcl_ExternalToUtfDString(encoding, string, length, &ds);
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 |
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
return TCL_ERROR;
}
if (objc >= 3) { /* process the optional info argument */
info = Tcl_GetStringFromObj(objv[2], &infoLen);
| | | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 |
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "message ?errorInfo? ?errorCode?");
return TCL_ERROR;
}
if (objc >= 3) { /* process the optional info argument */
info = Tcl_GetStringFromObj(objv[2], &infoLen);
if (infoLen > 0) {
Tcl_AddObjErrorInfo(interp, info, infoLen);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
if (objc == 4) {
Tcl_SetVar2Ex(interp, "errorCode", NULL, objv[3], TCL_GLOBAL_ONLY);
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result;
register Tcl_Obj *objPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
return TCL_ERROR;
}
if (objc == 2) {
result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result. Tcl_EvalObjEx will delete
* the object when it decrements its refcount after eval'ing it.
*/
objPtr = Tcl_ConcatObj(objc-1, objv+1);
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
| > > > > > > > > > > > > > > | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result;
register Tcl_Obj *objPtr;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
return TCL_ERROR;
}
if (objc == 2) {
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[1], TCL_EVAL_DIRECT);
#else
/* TIP #280. Make invoking context available to eval'd script */
result = TclEvalObjEx(interp, objv[1], TCL_EVAL_DIRECT,
iPtr->cmdFramePtr,1);
#endif
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result. Tcl_EvalObjEx will delete
* the object when it decrements its refcount after eval'ing it.
*/
objPtr = Tcl_ConcatObj(objc-1, objv+1);
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
#else
/* TIP #280. Make invoking context available to eval'd script */
result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
#endif
}
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"eval\" body line %d)", interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 | * * This procedure is invoked to process the "file" Tcl command. * See the user documentation for details on what it does. * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC. * With the object-based Tcl_FS APIs, the above NOTE may no * longer be true. In any case this assertion should be tested. | | | 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 | * * This procedure is invoked to process the "file" Tcl command. * See the user documentation for details on what it does. * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH * EMBEDDED NULLS, WHICH COULD THEORETICALLY HAPPEN ON A MAC. * With the object-based Tcl_FS APIs, the above NOTE may no * longer be true. In any case this assertion should be tested. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
797 798 799 800 801 802 803 |
"pathtype", "readable", "readlink", "rename",
"rootname", "separator", "size", "split",
"stat", "system",
"tail", "type", "volumes", "writable",
(char *) NULL
};
enum options {
| | | | | | | | | | | | > > | < | | 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 |
"pathtype", "readable", "readlink", "rename",
"rootname", "separator", "size", "split",
"stat", "system",
"tail", "type", "volumes", "writable",
(char *) NULL
};
enum options {
FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY,
FCMD_DELETE,
FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION,
FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK,
FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME,
FCMD_NORMALIZE, FCMD_OWNED,
FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME,
FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT,
FCMD_STAT, FCMD_SYSTEM,
FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case FCMD_ATIME: {
Tcl_StatBuf buf;
struct utimbuf tval;
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 4) {
long newTime;
if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
return TCL_ERROR;
}
tval.actime = newTime;
tval.modtime = buf.st_mtime;
if (Tcl_FSUtime(objv[2], &tval) != 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not set access time for file \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
857 858 859 860 861 862 863 |
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_atime);
return TCL_OK;
}
| | | | | | | | | | | | | | 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_atime);
return TCL_OK;
}
case FCMD_ATTRIBUTES: {
return TclFileAttrsCmd(interp, objc, objv);
}
case FCMD_CHANNELS: {
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
return Tcl_GetChannelNamesEx(interp,
((objc == 2) ? NULL : Tcl_GetString(objv[2])));
}
case FCMD_COPY: {
return TclFileCopyCmd(interp, objc, objv);
}
case FCMD_DELETE: {
return TclFileDeleteCmd(interp, objc, objv);
}
case FCMD_DIRNAME: {
Tcl_Obj *dirPtr;
if (objc != 3) {
goto only3Args;
}
dirPtr = TclFileDirname(interp, objv[2]);
if (dirPtr == NULL) {
return TCL_ERROR;
} else {
Tcl_SetObjResult(interp, dirPtr);
Tcl_DecrRefCount(dirPtr);
return TCL_OK;
}
}
case FCMD_EXECUTABLE: {
if (objc != 3) {
goto only3Args;
}
return CheckAccess(interp, objv[2], X_OK);
}
case FCMD_EXISTS: {
if (objc != 3) {
goto only3Args;
}
return CheckAccess(interp, objv[2], F_OK);
}
case FCMD_EXTENSION: {
char *fileName, *extension;
if (objc != 3) {
goto only3Args;
}
fileName = Tcl_GetString(objv[2]);
extension = TclGetExtension(fileName);
if (extension != NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp), extension, -1);
}
return TCL_OK;
}
case FCMD_ISDIRECTORY: {
int value;
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
value = 0;
if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
value = S_ISDIR(buf.st_mode);
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
case FCMD_ISFILE: {
int value;
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
value = 0;
if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
value = S_ISREG(buf.st_mode);
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
case FCMD_JOIN: {
Tcl_Obj *resObj;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
return TCL_ERROR;
}
resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2);
Tcl_SetObjResult(interp, resObj);
return TCL_OK;
}
case FCMD_LINK: {
Tcl_Obj *contents;
int index;
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-linktype? linkname ?target?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 | * result refCount. If we are creating a link, this * will just be objv[index+1], and so we don't own it. */ Tcl_DecrRefCount(contents); } return TCL_OK; } | | | > > | < | | | | > > > | | 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 |
* result refCount. If we are creating a link, this
* will just be objv[index+1], and so we don't own it.
*/
Tcl_DecrRefCount(contents);
}
return TCL_OK;
}
case FCMD_LSTAT: {
char *varName;
Tcl_StatBuf buf;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name varName");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
varName = Tcl_GetString(objv[3]);
return StoreStatData(interp, varName, &buf);
}
case FCMD_MTIME: {
Tcl_StatBuf buf;
struct utimbuf tval;
if ((objc < 3) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 4) {
long newTime;
if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) {
return TCL_ERROR;
}
tval.actime = buf.st_atime;
tval.modtime = newTime;
if (Tcl_FSUtime(objv[2], &tval) != 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not set modification time for file \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
/*
* Do another stat to ensure that the we return the
* new recognized atime - hopefully the same as the
* one we sent in. However, fs's like FAT don't
* even know what atime is.
*/
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_mtime);
return TCL_OK;
}
case FCMD_MKDIR: {
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
return TCL_ERROR;
}
return TclFileMakeDirsCmd(interp, objc, objv);
}
case FCMD_NATIVENAME: {
CONST char *fileName;
Tcl_DString ds;
if (objc != 3) {
goto only3Args;
}
fileName = Tcl_GetString(objv[2]);
fileName = Tcl_TranslateFileName(interp, fileName, &ds);
if (fileName == NULL) {
return TCL_ERROR;
}
Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
return TCL_OK;
}
case FCMD_NORMALIZE: {
Tcl_Obj *fileName;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "filename");
return TCL_ERROR;
}
fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
if (fileName == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, fileName);
return TCL_OK;
}
case FCMD_OWNED: {
int value;
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
value = 0;
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 | #else value = (geteuid() == buf.st_uid); #endif } Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value); return TCL_OK; } | | | | | 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 |
#else
value = (geteuid() == buf.st_uid);
#endif
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
return TCL_OK;
}
case FCMD_PATHTYPE: {
if (objc != 3) {
goto only3Args;
}
switch (Tcl_FSGetPathType(objv[2])) {
case TCL_PATH_ABSOLUTE:
Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1);
break;
case TCL_PATH_RELATIVE:
Tcl_SetStringObj(Tcl_GetObjResult(interp), "relative", -1);
break;
case TCL_PATH_VOLUME_RELATIVE:
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"volumerelative", -1);
break;
}
return TCL_OK;
}
case FCMD_READABLE: {
if (objc != 3) {
goto only3Args;
}
return CheckAccess(interp, objv[2], R_OK);
}
case FCMD_READLINK: {
Tcl_Obj *contents;
if (objc != 3) {
goto only3Args;
}
if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 | Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, contents); Tcl_DecrRefCount(contents); return TCL_OK; } | | | | | 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 |
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, contents);
Tcl_DecrRefCount(contents);
return TCL_OK;
}
case FCMD_RENAME: {
return TclFileRenameCmd(interp, objc, objv);
}
case FCMD_ROOTNAME: {
int length;
char *fileName, *extension;
if (objc != 3) {
goto only3Args;
}
fileName = Tcl_GetStringFromObj(objv[2], &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_SetObjResult(interp, objv[2]);
} else {
Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
(int) (length - strlen(extension)));
}
return TCL_OK;
}
case FCMD_SEPARATOR: {
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 2, objv, "?name?");
return TCL_ERROR;
}
if (objc == 2) {
char *separator = NULL; /* lint */
switch (tclPlatform) {
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 |
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Unrecognised path",-1));
return TCL_ERROR;
}
}
return TCL_OK;
}
| | | | | | | 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Unrecognised path",-1));
return TCL_ERROR;
}
}
return TCL_OK;
}
case FCMD_SIZE: {
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetWideIntObj(Tcl_GetObjResult(interp),
(Tcl_WideInt) buf.st_size);
return TCL_OK;
}
case FCMD_SPLIT: {
if (objc != 3) {
goto only3Args;
}
Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL));
return TCL_OK;
}
case FCMD_STAT: {
char *varName;
Tcl_StatBuf buf;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
varName = Tcl_GetString(objv[3]);
return StoreStatData(interp, varName, &buf);
}
case FCMD_SYSTEM: {
Tcl_Obj* fsInfo;
if (objc != 3) {
goto only3Args;
}
fsInfo = Tcl_FSFileSystemInfo(objv[2]);
if (fsInfo != NULL) {
Tcl_SetObjResult(interp, fsInfo);
return TCL_OK;
} else {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("Unrecognised path",-1));
return TCL_ERROR;
}
}
case FCMD_TAIL: {
int splitElements;
Tcl_Obj *splitPtr;
if (objc != 3) {
goto only3Args;
}
/*
|
| ︙ | ︙ | |||
1340 1341 1342 1343 1344 1345 1346 | Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail); Tcl_SetObjResult(interp, tail); } } Tcl_DecrRefCount(splitPtr); return TCL_OK; } | | | | | 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 |
Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail);
Tcl_SetObjResult(interp, tail);
}
}
Tcl_DecrRefCount(splitPtr);
return TCL_OK;
}
case FCMD_TYPE: {
Tcl_StatBuf buf;
if (objc != 3) {
goto only3Args;
}
if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetStringObj(Tcl_GetObjResult(interp),
GetTypeFromMode((unsigned short) buf.st_mode), -1);
return TCL_OK;
}
case FCMD_VOLUMES: {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_FSListVolumes());
return TCL_OK;
}
case FCMD_WRITABLE: {
if (objc != 3) {
goto only3Args;
}
return CheckAccess(interp, objv[2], W_OK);
}
}
|
| ︙ | ︙ | |||
1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 |
Tcl_ForObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
return TCL_ERROR;
}
result = Tcl_EvalObjEx(interp, objv[1], 0);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
}
return result;
}
while (1) {
| > > > > > > > > | 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 |
Tcl_ForObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
return TCL_ERROR;
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[1], 0);
#else
/* TIP #280. Make invoking context available to initial script */
result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr,1);
#endif
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
}
return result;
}
while (1) {
|
| ︙ | ︙ | |||
1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 |
result = Tcl_ExprBooleanObj(interp, objv[2], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
result = Tcl_EvalObjEx(interp, objv[4], 0);
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
}
result = Tcl_EvalObjEx(interp, objv[3], 0);
if (result == TCL_BREAK) {
break;
} else if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
}
return result;
| > > > > > > > > > > | 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 |
result = Tcl_ExprBooleanObj(interp, objv[2], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[4], 0);
#else
/* TIP #280. Make invoking context available to loop body */
result = TclEvalObjEx(interp, objv[4], 0, iPtr->cmdFramePtr,4);
#endif
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[3], 0);
#else
/* TIP #280. Make invoking context available to next script */
result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3);
#endif
if (result == TCL_BREAK) {
break;
} else if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
}
return result;
|
| ︙ | ︙ | |||
1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 |
Tcl_Obj **argvListArray[STATIC_LIST_SIZE];
int *index = indexArray; /* Array of value list indices */
int *varcList = varcListArray; /* # loop variables per list */
Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */
int *argcList = argcListArray; /* Array of value list sizes */
Tcl_Obj ***argvList = argvListArray; /* Array of value lists */
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
"varList list ?varList list ...? command");
return TCL_ERROR;
}
| > > > | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 |
Tcl_Obj **argvListArray[STATIC_LIST_SIZE];
int *index = indexArray; /* Array of value list indices */
int *varcList = varcListArray; /* # loop variables per list */
Tcl_Obj ***varvList = varvListArray; /* Array of var name lists */
int *argcList = argcListArray; /* Array of value list sizes */
Tcl_Obj ***argvList = argvListArray; /* Array of value lists */
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
"varList list ?varList list ...? command");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1826 1827 1828 1829 1830 1831 1832 |
if (result != TCL_OK) {
panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
}
for (v = 0; v < varcList[i]; v++) {
int k = index[i]++;
Tcl_Obj *valuePtr, *varValuePtr;
| < < > < < | < > > > > > > | 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 |
if (result != TCL_OK) {
panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
}
for (v = 0; v < varcList[i]; v++) {
int k = index[i]++;
Tcl_Obj *valuePtr, *varValuePtr;
if (k < argcList[i]) {
valuePtr = argvList[i][k];
} else {
valuePtr = Tcl_NewObj(); /* empty string */
}
Tcl_IncrRefCount(valuePtr);
varValuePtr = Tcl_ObjSetVar2(interp, varvList[i][v],
NULL, valuePtr, 0);
Tcl_DecrRefCount(valuePtr);
if (varValuePtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't set loop variable: \"",
Tcl_GetString(varvList[i][v]), "\"", (char *) NULL);
result = TCL_ERROR;
goto done;
}
}
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, bodyPtr, 0);
#else
/* TIP #280. Make invoking context available to loop body */
result = TclEvalObjEx(interp, bodyPtr, 0, iPtr->cmdFramePtr,objc-1);
#endif
if (result != TCL_OK) {
if (result == TCL_CONTINUE) {
result = TCL_OK;
} else if (result == TCL_BREAK) {
result = TCL_OK;
break;
} else if (result == TCL_ERROR) {
|
| ︙ | ︙ | |||
1933 1934 1935 1936 1937 1938 1939 |
* ("e", "s", etc.), width, and precision. */
long intValue; /* Used to hold value to pass to sprintf, if
* it's a one-word integer or char value */
char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if
* it's a one-word value. */
double doubleValue; /* Used to hold value to pass to sprintf if
* it's a double value. */
| < < | | < < | < < | 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 |
* ("e", "s", etc.), width, and precision. */
long intValue; /* Used to hold value to pass to sprintf, if
* it's a one-word integer or char value */
char *ptrValue = NULL; /* Used to hold value to pass to sprintf, if
* it's a one-word value. */
double doubleValue; /* Used to hold value to pass to sprintf if
* it's a double value. */
Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if
* it's a 'long long' value. */
int whichValue; /* Indicates which of intValue, ptrValue,
* or doubleValue has the value to pass to
* sprintf, according to the following
* definitions: */
# define INT_VALUE 0
# define CHAR_VALUE 1
# define PTR_VALUE 2
# define DOUBLE_VALUE 3
# define STRING_VALUE 4
# define WIDE_VALUE 5
# define MAX_FLOAT_SIZE 320
Tcl_Obj *resultPtr; /* Where result is stored finally. */
char staticBuf[MAX_FLOAT_SIZE + 1];
/* A static buffer to copy the format results
* into */
char *dst = staticBuf; /* The buffer that sprintf writes into each
* time the format processes a specifier */
int dstSize = MAX_FLOAT_SIZE;
/* The size of the dst buffer */
int noPercent; /* Special case for speed: indicates there's
* no field specifier, just a string to copy.*/
int objIndex; /* Index of argument to substitute next. */
int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style
* specifier has been seen. */
int gotSequential = 0; /* Non-zero means that a regular sequential
* (non-XPG3) conversion specifier has been
* seen. */
int useShort; /* Value to be printed is short (half word). */
char *end; /* Used to locate end of numerical fields. */
int stringLen = 0; /* Length of string in characters rather
* than bytes. Used for %s substitution. */
int gotMinus; /* Non-zero indicates that a minus flag has
* been seen in the current field. */
int gotPrecision; /* Non-zero indicates that a precision has
* been set for the current field. */
int gotZero; /* Non-zero indicates that a zero flag has
* been seen in the current field. */
int useWide; /* Value to be printed is Tcl_WideInt. */
/*
* This procedure is a bit nasty. The goal is to use sprintf to
* do most of the dirty work. There are several problems:
* 1. this procedure can't trust its arguments.
* 2. we must be able to provide a large enough result area to hold
* whatever's generated. This is hard to estimate.
* 3. there's no way to move the arguments from objv to the call
* to sprintf in a reasonable way. This is particularly nasty
* because some of the arguments may be two-word values (doubles
* and wide-ints).
* So, what happens here is to scan the format string one % group
* at a time, making many individual calls to sprintf.
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
return TCL_ERROR;
}
format = Tcl_GetStringFromObj(objv[1], &formatLen);
endPtr = format + formatLen;
resultPtr = Tcl_NewObj();
objIndex = 2;
while (format < endPtr) {
register char *newPtr = newFormat;
width = precision = noPercent = useShort = 0;
gotZero = gotMinus = gotPrecision = 0;
useWide = 0;
whichValue = PTR_VALUE;
/*
* Get rid of any characters before the next field specifier.
*/
if (*format != '%') {
ptrValue = format;
|
| ︙ | ︙ | |||
2154 2155 2156 2157 2158 2159 2160 |
if (gotPrecision) {
TclFormatInt(newPtr, precision); /* INTL: printf format. */
while (*newPtr != 0) {
newPtr++;
}
}
if (*format == 'l') {
| < > > > > > > > > > > > | | < > | | | | | | | < | | | | | | | | | < | | > > > > > > | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > | | | | | 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 |
if (gotPrecision) {
TclFormatInt(newPtr, precision); /* INTL: printf format. */
while (*newPtr != 0) {
newPtr++;
}
}
if (*format == 'l') {
useWide = 1;
/*
* Only add a 'll' modifier for integer values as it makes
* some libc's go into spasm otherwise. [Bug #702622]
*/
switch (format[1]) {
case 'i':
case 'd':
case 'o':
case 'u':
case 'x':
case 'X':
strcpy(newPtr, TCL_LL_MODIFIER);
newPtr += TCL_LL_MODIFIER_SIZE;
}
format++;
} else if (*format == 'h') {
useShort = 1;
*newPtr = 'h';
newPtr++;
format++;
}
*newPtr = *format;
newPtr++;
*newPtr = 0;
if (objIndex >= objc) {
goto badIndex;
}
switch (*format) {
case 'i':
newPtr[-1] = 'd';
case 'd':
case 'o':
case 'u':
case 'x':
case 'X':
if (useWide) {
if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &wideValue) != TCL_OK) {
goto fmtError;
}
whichValue = WIDE_VALUE;
size = 40 + precision;
break;
}
if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &intValue) != TCL_OK) {
if (Tcl_GetWideIntFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &wideValue) != TCL_OK) {
goto fmtError;
}
intValue = Tcl_WideAsLong(wideValue);
}
#if (LONG_MAX > INT_MAX)
if (!useShort) {
/*
* Add the 'l' for long format type because we are on an
* LP64 archtecture and we are really going to pass a long
* argument to sprintf.
*
* Do not add this if we're going to pass in a short (i.e.
* if we've got an 'h' modifier already in the string); some
* libc implementations of sprintf() do not like it at all.
* [Bug 1154163]
*/
newPtr++;
*newPtr = 0;
newPtr[-1] = newPtr[-2];
newPtr[-2] = 'l';
}
#endif /* LONG_MAX > INT_MAX */
whichValue = INT_VALUE;
size = 40 + precision;
break;
case 's':
/*
* Compute the length of the string in characters and add
* any additional space required by the field width. All
* of the extra characters will be spaces, so one byte per
* character is adequate.
*/
whichValue = STRING_VALUE;
ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
stringLen = Tcl_NumUtfChars(ptrValue, size);
if (gotPrecision && (precision < stringLen)) {
stringLen = precision;
}
size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
if (width > stringLen) {
size += (width - stringLen);
}
break;
case 'c':
if (Tcl_GetLongFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &intValue) != TCL_OK) {
goto fmtError;
}
whichValue = CHAR_VALUE;
size = width + TCL_UTF_MAX;
break;
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */
objv[objIndex], &doubleValue) != TCL_OK) {
goto fmtError;
}
whichValue = DOUBLE_VALUE;
size = MAX_FLOAT_SIZE;
if (precision > 10) {
size += precision;
}
break;
case 0:
Tcl_SetResult(interp,
"format string ended in middle of field specifier",
TCL_STATIC);
goto fmtError;
default:
{
char buf[40];
sprintf(buf, "bad field specifier \"%c\"", *format);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
goto fmtError;
}
}
objIndex++;
format++;
/*
* Make sure that there's enough space to hold the formatted
* result, then format it.
|
| ︙ | ︙ | |||
2286 2287 2288 2289 2290 2291 2292 |
if (dst != staticBuf) {
ckfree(dst);
}
dst = (char *) ckalloc((unsigned) (size + 1));
dstSize = size;
}
switch (whichValue) {
| | | | < < | | | < < | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | > > > > > > > > > | 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 |
if (dst != staticBuf) {
ckfree(dst);
}
dst = (char *) ckalloc((unsigned) (size + 1));
dstSize = size;
}
switch (whichValue) {
case DOUBLE_VALUE:
sprintf(dst, newFormat, doubleValue); /* INTL: user locale. */
break;
case WIDE_VALUE:
sprintf(dst, newFormat, wideValue);
break;
case INT_VALUE:
if (useShort) {
sprintf(dst, newFormat, (short) intValue);
} else {
sprintf(dst, newFormat, intValue);
}
break;
case CHAR_VALUE: {
char *ptr;
char padChar = (gotZero ? '0' : ' ');
ptr = dst;
if (!gotMinus) {
for ( ; --width > 0; ptr++) {
*ptr = padChar;
}
}
ptr += Tcl_UniCharToUtf(intValue, ptr);
for ( ; --width > 0; ptr++) {
*ptr = padChar;
}
*ptr = '\0';
break;
}
case STRING_VALUE: {
char *ptr;
char padChar = (gotZero ? '0' : ' ');
int pad;
ptr = dst;
if (width > stringLen) {
pad = width - stringLen;
} else {
pad = 0;
}
if (!gotMinus) {
while (pad > 0) {
*ptr++ = padChar;
pad--;
}
}
size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue;
if (size) {
memcpy(ptr, ptrValue, (size_t) size);
ptr += size;
}
while (pad > 0) {
*ptr++ = padChar;
pad--;
}
*ptr = '\0';
break;
}
default:
sprintf(dst, newFormat, ptrValue);
break;
}
Tcl_AppendToObj(resultPtr, dst, -1);
}
}
Tcl_SetObjResult(interp, resultPtr);
if (dst != staticBuf) {
ckfree(dst);
}
return TCL_OK;
mixedXPG:
Tcl_SetResult(interp,
"cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
goto fmtError;
badIndex:
if (gotXpg) {
Tcl_SetResult(interp,
"\"%n$\" argument index out of range", TCL_STATIC);
} else {
Tcl_SetResult(interp,
"not enough arguments for all format specifiers", TCL_STATIC);
}
fmtError:
if (dst != staticBuf) {
ckfree(dst);
}
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCmdIL.c,v 1.47.2.11 2007/03/10 14:57:38 dkf Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclRegexp.h" /* |
| ︙ | ︙ | |||
105 106 107 108 109 110 111 112 113 114 115 116 117 118 | Tcl_Obj *CONST objv[])); static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy, | > > > > > > | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | Tcl_Obj *CONST objv[])); static int InfoDefaultCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int InfoExistsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); #ifdef TCL_TIP280 /* TIP #280 - New 'info' subcommand 'frame' */ static int InfoFrameCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); #endif static int InfoFunctionsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int InfoGlobalsCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int InfoHostnameCmd _ANSI_ARGS_((ClientData dummy, |
| ︙ | ︙ | |||
184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
Tcl_IfObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int thenScriptIndex = 0; /* then script to be evaled after syntax check */
int i, result, value;
char *clause;
i = 1;
while (1) {
/*
* At this point in the loop, objv and objc refer to an expression
* to test, either for the main expression or an expression
| > > > | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
Tcl_IfObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int thenScriptIndex = 0; /* then script to be evaled after syntax check */
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
int i, result, value;
char *clause;
i = 1;
while (1) {
/*
* At this point in the loop, objv and objc refer to an expression
* to test, either for the main expression or an expression
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
* The expression evaluated to false. Skip the command, then
* see if there is an "else" or "elseif" clause.
*/
i++;
if (i >= objc) {
if (thenScriptIndex) {
return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
}
return TCL_OK;
}
clause = Tcl_GetString(objv[i]);
if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
i++;
continue;
| > > > > > > | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 |
* The expression evaluated to false. Skip the command, then
* see if there is an "else" or "elseif" clause.
*/
i++;
if (i >= objc) {
if (thenScriptIndex) {
#ifndef TCL_TIP280
return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
#else
/* TIP #280. Make invoking context available to branch */
return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr,thenScriptIndex);
#endif
}
return TCL_OK;
}
clause = Tcl_GetString(objv[i]);
if ((clause[0] == 'e') && (strcmp(clause, "elseif") == 0)) {
i++;
continue;
|
| ︙ | ︙ | |||
270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
if (i < objc - 1) {
Tcl_AppendResult(interp,
"wrong # args: extra words after \"else\" clause in \"if\" command",
(char *) NULL);
return TCL_ERROR;
}
if (thenScriptIndex) {
return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
}
return Tcl_EvalObjEx(interp, objv[i], 0);
}
/*
*----------------------------------------------------------------------
*
* Tcl_IncrObjCmd --
*
| > > > > > > > > > > | 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 |
if (i < objc - 1) {
Tcl_AppendResult(interp,
"wrong # args: extra words after \"else\" clause in \"if\" command",
(char *) NULL);
return TCL_ERROR;
}
if (thenScriptIndex) {
#ifndef TCL_TIP280
return Tcl_EvalObjEx(interp, objv[thenScriptIndex], 0);
#else
/* TIP #280. Make invoking context available to branch/else */
return TclEvalObjEx(interp, objv[thenScriptIndex], 0,
iPtr->cmdFramePtr,thenScriptIndex);
#endif
}
#ifndef TCL_TIP280
return Tcl_EvalObjEx(interp, objv[i], 0);
#else
return TclEvalObjEx(interp, objv[i], 0, iPtr->cmdFramePtr,i);
#endif
}
/*
*----------------------------------------------------------------------
*
* Tcl_IncrObjCmd --
*
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 |
/*
* Calculate the amount to increment by.
*/
if (objc == 2) {
incrAmount = 1;
} else {
| < < | < | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
/*
* Calculate the amount to increment by.
*/
if (objc == 2) {
incrAmount = 1;
} else {
if (Tcl_GetLongFromObj(interp, objv[2], &incrAmount) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
/*
* Need to be a bit cautious to ensure that [expr]-like rules
* are enforced for interpretation of wide integers, despite
* the fact that the underlying API itself is a 'long' only one.
*/
if (objv[2]->typePtr == &tclIntType) {
incrAmount = objv[2]->internalRep.longValue;
} else if (objv[2]->typePtr == &tclWideIntType) {
TclGetLongFromWide(incrAmount,objv[2]);
} else {
Tcl_WideInt wide;
if (Tcl_GetWideIntFromObj(interp, objv[2], &wide) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (reading increment)");
return TCL_ERROR;
}
incrAmount = Tcl_WideAsLong(wide);
if ((wide <= Tcl_LongAsWide(LONG_MAX))
&& (wide >= Tcl_LongAsWide(LONG_MIN))) {
objv[2]->typePtr = &tclIntType;
objv[2]->internalRep.longValue = incrAmount;
}
}
}
/*
* Increment the variable's value.
*/
newValuePtr = TclIncrVar2(interp, objv[1], (Tcl_Obj *) NULL, incrAmount,
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 |
Tcl_InfoObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Arbitrary value passed to the command. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
| | | > > > > | | > > > > | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 |
Tcl_InfoObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Arbitrary value passed to the command. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
"args", "body", "cmdcount", "commands",
"complete", "default", "exists",
#ifdef TCL_TIP280
"frame",
#endif
"functions",
"globals", "hostname", "level", "library", "loaded",
"locals", "nameofexecutable", "patchlevel", "procs",
"script", "sharedlibextension", "tclversion", "vars",
(char *) NULL};
enum ISubCmdIdx {
IArgsIdx, IBodyIdx, ICmdCountIdx, ICommandsIdx,
ICompleteIdx, IDefaultIdx, IExistsIdx,
#ifdef TCL_TIP280
IFrameIdx,
#endif
IFunctionsIdx,
IGlobalsIdx, IHostnameIdx, ILevelIdx, ILibraryIdx, ILoadedIdx,
ILocalsIdx, INameOfExecutableIdx, IPatchLevelIdx, IProcsIdx,
IScriptIdx, ISharedLibExtensionIdx, ITclVersionIdx, IVarsIdx
};
int index, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 451 452 453 454 455 456 457 |
break;
case IDefaultIdx:
result = InfoDefaultCmd(clientData, interp, objc, objv);
break;
case IExistsIdx:
result = InfoExistsCmd(clientData, interp, objc, objv);
break;
case IFunctionsIdx:
result = InfoFunctionsCmd(clientData, interp, objc, objv);
break;
case IGlobalsIdx:
result = InfoGlobalsCmd(clientData, interp, objc, objv);
break;
case IHostnameIdx:
| > > > > > > | 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 |
break;
case IDefaultIdx:
result = InfoDefaultCmd(clientData, interp, objc, objv);
break;
case IExistsIdx:
result = InfoExistsCmd(clientData, interp, objc, objv);
break;
#ifdef TCL_TIP280
case IFrameIdx:
/* TIP #280 - New method 'frame' */
result = InfoFrameCmd(clientData, interp, objc, objv);
break;
#endif
case IFunctionsIdx:
result = InfoFunctionsCmd(clientData, interp, objc, objv);
break;
case IGlobalsIdx:
result = InfoGlobalsCmd(clientData, interp, objc, objv);
break;
case IHostnameIdx:
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 |
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
/*
* Scan through the effective namespace's command table and create a
* list with all commands that match the pattern. If a specific
* namespace was requested in the pattern, qualify the command names
* with the namespace name.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
| > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 |
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
/*
* Exit as quickly as possible if we couldn't find the namespace.
*/
if (nsPtr == NULL) {
return TCL_OK;
}
/*
* Scan through the effective namespace's command table and create a
* list with all commands that match the pattern. If a specific
* namespace was requested in the pattern, qualify the command names
* with the namespace name.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
/*
* Special case for when the pattern doesn't include any of
* glob's special characters. This lets us avoid scans of any
* hash tables.
*/
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
} else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable,
simplePattern);
if (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
}
} else {
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
|
| ︙ | ︙ | |||
898 899 900 901 902 903 904 905 906 |
"couldn't store default value in variable \"",
varName, "\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_Obj *nullObjPtr = Tcl_NewObj();
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
nullObjPtr, 0);
| > < | > | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 |
"couldn't store default value in variable \"",
varName, "\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_Obj *nullObjPtr = Tcl_NewObj();
Tcl_IncrRefCount(nullObjPtr);
valueObjPtr = Tcl_ObjSetVar2(interp, objv[4], NULL,
nullObjPtr, 0);
Tcl_DecrRefCount(nullObjPtr); /* free unneeded obj */
if (valueObjPtr == NULL) {
goto defStoreError;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
}
|
| ︙ | ︙ | |||
960 961 962 963 964 965 966 967 968 969 970 971 972 973 |
if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* InfoFunctionsCmd --
*
* Called to implement the "info functions" command that returns the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 |
if ((varPtr != NULL) && !TclIsVarUndefined(varPtr)) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 1);
} else {
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
}
return TCL_OK;
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
* InfoFrameCmd --
* TIP #280
*
* Called to implement the "info frame" command that returns the
* location of either the currently executing command, or its caller.
* Handles the following syntax:
*
* info frame ?number?
*
* Results:
* Returns TCL_OK if successful and TCL_ERROR if there is an error.
*
* Side effects:
* Returns a result in the interpreter's result object. If there is
* an error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoFrameCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if (objc == 2) {
/* just "info frame" */
int levels = (iPtr->cmdFramePtr == NULL
? 0
: iPtr->cmdFramePtr->level);
Tcl_SetIntObj(Tcl_GetObjResult(interp), levels);
return TCL_OK;
} else if (objc == 3) {
/* "info frame level" */
int level;
CmdFrame *framePtr;
if (Tcl_GetIntFromObj(interp, objv[2], &level) != TCL_OK) {
return TCL_ERROR;
}
if (level <= 0) {
/* Relative adressing */
if (iPtr->cmdFramePtr == NULL) {
levelError:
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad level \"",
Tcl_GetString(objv[2]),
"\"", (char *) NULL);
return TCL_ERROR;
}
/* Convert to absolute. */
level += iPtr->cmdFramePtr->level;
}
for (framePtr = iPtr->cmdFramePtr;
framePtr != NULL;
framePtr = framePtr->nextPtr) {
if (framePtr->level == level) {
break;
}
}
if (framePtr == NULL) {
goto levelError;
}
/*
* Pull the information and construct the dictionary to return, as
* list. Regarding use of the CmdFrame fields see tclInt.h, and its
* definition.
*/
{
Tcl_Obj* lv [20]; /* Keep uptodate when more keys are added to the dict */
int lc = 0;
/* This array is indexed by the TCL_LOCATION_... values, except
* for _LAST.
*/
static CONST char* typeString [TCL_LOCATION_LAST] = {
"eval", "eval", "eval", "precompiled", "source", "proc"
};
switch (framePtr->type) {
case TCL_LOCATION_EVAL:
/* Evaluation, dynamic script. Type, line, cmd, the latter
* through str. */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
lv [lc ++] = Tcl_NewStringObj ("line",-1);
lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
framePtr->cmd.str.len);
break;
case TCL_LOCATION_EVAL_LIST:
/* List optimized evaluation. Type, line, cmd, the latter
* through listPtr, possibly a frame. */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
lv [lc ++] = Tcl_NewStringObj ("line",-1);
lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
/* We put a duplicate of the command list obj into the result
* to ensure that the 'pure List'-property of the command
* itself is not destroyed. Otherwise the query here would
* disable the list optimization path in Tcl_EvalObjEx.
*/
lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
lv [lc ++] = Tcl_DuplicateObj (framePtr->cmd.listPtr);
break;
case TCL_LOCATION_PREBC:
/* Precompiled. Result contains the type as signal, nothing
* else */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
break;
case TCL_LOCATION_BC: {
/* Execution of bytecode. Talk to the BC engine to fill out
* the frame. */
CmdFrame f = *framePtr;
Proc* procPtr = f.framePtr ? f.framePtr->procPtr : NULL;
/* Note: Type BC => f.data.eval.path is not used.
* f.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc (&f);
/* Now filled: cmd.str.(cmd,len), line */
/* Possibly modified: type, path! */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [f.type],-1);
lv [lc ++] = Tcl_NewStringObj ("line",-1);
lv [lc ++] = Tcl_NewIntObj (f.line[0]);
if (f.type == TCL_LOCATION_SOURCE) {
lv [lc ++] = Tcl_NewStringObj ("file",-1);
lv [lc ++] = f.data.eval.path;
/* Death of reference by TclGetSrcInfoForPc */
Tcl_DecrRefCount (f.data.eval.path);
}
lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
lv [lc ++] = Tcl_NewStringObj (f.cmd.str.cmd, f.cmd.str.len);
if (procPtr != NULL) {
Tcl_HashEntry* namePtr = procPtr->cmdPtr->hPtr;
char* procName = Tcl_GetHashKey (namePtr->tablePtr, namePtr);
char* nsName = procPtr->cmdPtr->nsPtr->fullName;
lv [lc ++] = Tcl_NewStringObj ("proc",-1);
lv [lc ++] = Tcl_NewStringObj (nsName,-1);
if (strcmp (nsName, "::") != 0) {
Tcl_AppendToObj (lv [lc-1], "::", -1);
}
Tcl_AppendToObj (lv [lc-1], procName, -1);
}
break;
}
case TCL_LOCATION_SOURCE:
/* Evaluation of a script file */
lv [lc ++] = Tcl_NewStringObj ("type",-1);
lv [lc ++] = Tcl_NewStringObj (typeString [framePtr->type],-1);
lv [lc ++] = Tcl_NewStringObj ("line",-1);
lv [lc ++] = Tcl_NewIntObj (framePtr->line[0]);
lv [lc ++] = Tcl_NewStringObj ("file",-1);
lv [lc ++] = framePtr->data.eval.path;
/* Refcount framePtr->data.eval.path goes up when lv
* is converted into the result list object.
*/
lv [lc ++] = Tcl_NewStringObj ("cmd",-1);
lv [lc ++] = Tcl_NewStringObj (framePtr->cmd.str.cmd,
framePtr->cmd.str.len);
break;
case TCL_LOCATION_PROC:
Tcl_Panic ("TCL_LOCATION_PROC found in standard frame");
break;
}
/* 'level'. Common to all frame types. Conditional on having an
* associated _visible_ CallFrame */
if ((framePtr->framePtr != NULL) && (iPtr->varFramePtr != NULL)) {
CallFrame* current = framePtr->framePtr;
CallFrame* top = iPtr->varFramePtr;
CallFrame* idx;
for (idx = top;
idx != NULL;
idx = idx->callerVarPtr) {
if (idx == current) {
int c = framePtr->framePtr->level;
int t = iPtr->varFramePtr->level;
lv [lc ++] = Tcl_NewStringObj ("level",-1);
lv [lc ++] = Tcl_NewIntObj (t - c);
break;
}
}
}
Tcl_SetObjResult(interp, Tcl_NewListObj (lc, lv));
return TCL_OK;
}
}
Tcl_WrongNumArgs(interp, 2, objv, "?number?");
return TCL_ERROR;
}
#endif
/*
*----------------------------------------------------------------------
*
* InfoFunctionsCmd --
*
* Called to implement the "info functions" command that returns the
|
| ︙ | ︙ | |||
1047 1048 1049 1050 1051 1052 1053 |
Tcl_HashSearch search;
Var *varPtr;
Tcl_Obj *listPtr;
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
| | > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | > | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 |
Tcl_HashSearch search;
Var *varPtr;
Tcl_Obj *listPtr;
if (objc == 2) {
pattern = NULL;
} else if (objc == 3) {
pattern = Tcl_GetString(objv[2]);
/*
* Strip leading global-namespace qualifiers. [Bug 1057461]
*/
if (pattern[0] == ':' && pattern[1] == ':') {
while (*pattern == ':') {
pattern++;
}
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
/*
* Scan through the global :: namespace's variable table and create a
* list of all global variables that match the pattern.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
if (pattern != NULL && TclMatchIsTrivial(pattern)) {
entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(pattern, -1));
}
}
} else {
for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (TclIsVarUndefined(varPtr)) {
continue;
}
varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 |
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
/*
* Scan through the effective namespace's command table and create a
* list with all procs that match the pattern. If a specific
* namespace was requested in the pattern, qualify the command names
* with the namespace name.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
| > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > | | > > | > | < < | 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 |
if (nsPtr != NULL) { /* we successfully found the pattern's ns */
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
if (nsPtr == NULL) {
return TCL_OK;
}
/*
* Scan through the effective namespace's command table and create a
* list with all procs that match the pattern. If a specific
* namespace was requested in the pattern, qualify the command names
* with the namespace name.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto simpleProcOK;
}
} else {
simpleProcOK:
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
} else
#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */
{
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto procOK;
}
} else {
procOK:
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
/*
|
| ︙ | ︙ | |||
1885 1886 1887 1888 1889 1890 1891 | /* * There is no frame pointer, the frame pointer was pushed only * to activate a namespace, or we are in a procedure call frame * but a specific namespace was specified. Create a list containing * only the variables in the effective namespace's variable table. */ | > > > > > > | | | | | < < < | | > > > > > > > > > | < | | > | < < < | < < | < | | | < | | > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 |
/*
* There is no frame pointer, the frame pointer was pushed only
* to activate a namespace, or we are in a procedure call frame
* but a specific namespace was specified. Create a list containing
* only the variables in the effective namespace's variable table.
*/
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
/*
* If we can just do hash lookups, that simplifies things
* a lot.
*/
entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
} else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable,
simplePattern);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(simplePattern, -1));
}
}
}
} else {
/*
* Have to scan the tables of variables.
*/
entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(varName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
/*
* If the effective namespace isn't the global ::
* namespace, and a specific namespace wasn't requested in
* the pattern (i.e., the pattern only specifies variable
* names), then add in all global :: variables that match
* the simple pattern. Of course, add in only those
* variables that aren't hidden by a variable in the
* effective namespace.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&globalNsPtr->varTable,
entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->varTable,
varName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
}
entryPtr = Tcl_NextHashEntry(&search);
}
}
}
} else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
AppendLocals(interp, listPtr, simplePattern, 1);
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
|
| ︙ | ︙ | |||
2890 2891 2892 2893 2894 2895 2896 |
}
}
}
if ((enum modes) mode == REGEXP) {
/*
* We can shimmer regexp/list if listv[i] == pattern, so get the
| | > > > > > > > > > > > > > | | > > | 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 |
}
}
}
if ((enum modes) mode == REGEXP) {
/*
* We can shimmer regexp/list if listv[i] == pattern, so get the
* regexp rep before the list rep. First time round, omit the interp
* and hope that the compilation will succeed. If it fails, we'll
* recompile in "expensive" mode with a place to put error messages.
*/
regexp = Tcl_GetRegExpFromObj(NULL, objv[objc - 1],
TCL_REG_ADVANCED | TCL_REG_NOSUB);
if (regexp == NULL) {
/*
* Failed to compile the RE. Try again without the TCL_REG_NOSUB
* flag in case the RE had sub-expressions in it [Bug 1366683].
* If this fails, an error message will be left in the
* interpreter.
*/
regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1],
TCL_REG_ADVANCED);
}
if (regexp == NULL) {
if (startPtr) {
Tcl_DecrRefCount(startPtr);
}
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
2924 2925 2926 2927 2928 2929 2930 2931 |
*/
if (startPtr) {
result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
Tcl_DecrRefCount(startPtr);
if (result != TCL_OK) {
return result;
}
if (offset > listc-1) {
| > > > > > > > > | > > > | 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 |
*/
if (startPtr) {
result = TclGetIntForIndex(interp, startPtr, listc-1, &offset);
Tcl_DecrRefCount(startPtr);
if (result != TCL_OK) {
return result;
}
/*
* If the search started past the end of the list, we just return a
* "did not match anything at all" result straight away. [Bug 1374778]
*/
if (offset > listc-1) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
}
return TCL_OK;
}
if (offset < 0) {
offset = 0;
}
}
patObj = objv[objc - 1];
|
| ︙ | ︙ | |||
3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 |
goto done;
}
elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
for (i=0; i < length; i++){
elementArray[i].objPtr = listObjPtrs[i];
elementArray[i].count = 0;
elementArray[i].nextPtr = &elementArray[i+1];
}
elementArray[length-1].nextPtr = NULL;
elementPtr = MergeSort(elementArray, &sortInfo);
if (sortInfo.resultCode == TCL_OK) {
/*
* Note: must clear the interpreter's result object: it could
* have been set by the -command script.
| > > > > > > > > > | 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 |
goto done;
}
elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
for (i=0; i < length; i++){
elementArray[i].objPtr = listObjPtrs[i];
elementArray[i].count = 0;
elementArray[i].nextPtr = &elementArray[i+1];
/*
* When sorting using a command, we are reentrant and therefore might
* have the representation of the list being sorted shimmered out from
* underneath our feet. Increment the reference counts of the elements
* to sort to prevent this. [Bug 1675116]
*/
Tcl_IncrRefCount(elementArray[i].objPtr);
}
elementArray[length-1].nextPtr = NULL;
elementPtr = MergeSort(elementArray, &sortInfo);
if (sortInfo.resultCode == TCL_OK) {
/*
* Note: must clear the interpreter's result object: it could
* have been set by the -command script.
|
| ︙ | ︙ | |||
3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 |
} else {
for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
Tcl_ListObjAppendElement(interp, resultPtr,
elementPtr->objPtr);
}
}
}
ckfree((char*) elementArray);
done:
if (sortInfo.sortMode == SORTMODE_COMMAND) {
Tcl_DecrRefCount(sortInfo.compareCmdPtr);
sortInfo.compareCmdPtr = NULL;
}
| > > > | 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 |
} else {
for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
Tcl_ListObjAppendElement(interp, resultPtr,
elementPtr->objPtr);
}
}
}
for (i=0; i<length; i++) {
Tcl_DecrRefCount(elementArray[i].objPtr);
}
ckfree((char*) elementArray);
done:
if (sortInfo.sortMode == SORTMODE_COMMAND) {
Tcl_DecrRefCount(sortInfo.compareCmdPtr);
sortInfo.compareCmdPtr = NULL;
}
|
| ︙ | ︙ | |||
3698 3699 3700 3701 3702 3703 3704 |
* Parse the result of the command.
*/
if (Tcl_GetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
Tcl_ResetResult(infoPtr->interp);
Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
| | | 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 |
* Parse the result of the command.
*/
if (Tcl_GetIntFromObj(infoPtr->interp,
Tcl_GetObjResult(infoPtr->interp), &order) != TCL_OK) {
Tcl_ResetResult(infoPtr->interp);
Tcl_AppendToObj(Tcl_GetObjResult(infoPtr->interp),
"-compare command returned non-integer result", -1);
infoPtr->resultCode = TCL_ERROR;
return order;
}
}
if (!infoPtr->isIncreasing) {
order = -order;
}
|
| ︙ | ︙ | |||
3840 3841 3842 3843 3844 3845 3846 |
}
}
if (diff == 0) {
diff = secondaryDiff;
}
return diff;
}
| > > > > > > > > > | 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 |
}
}
if (diff == 0) {
diff = secondaryDiff;
}
return diff;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * Copyright (c) 2002 ActiveState Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > | > > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 Scriptics Corporation.
* Copyright (c) 2002 ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclCmdMZ.c,v 1.82.2.28 2007/05/10 18:23:58 dgp Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include "tclRegexp.h"
#include "tclCompile.h"
/*
* Structures used to hold information about variable traces:
*/
typedef struct {
int flags; /* Operations for which Tcl command is
* to be invoked. */
size_t length; /* Number of non-NULL chars. in command. */
char command[4]; /* Space for Tcl command to invoke. Actual
* size will be as large as necessary to
* hold command. This field must be the
* last in the structure, so that it can
* be larger than 4 bytes. */
} TraceVarInfo;
typedef struct {
VarTrace trace;
TraceVarInfo tvar;
} CompoundVarTrace;
/*
* Structure used to hold information about command traces:
*/
typedef struct {
int flags; /* Operations for which Tcl command is
* to be invoked. */
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static void TraceCommandProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *oldName,
CONST char *newName, int flags));
static Tcl_CmdObjTraceProc TraceExecutionProc;
/*
*----------------------------------------------------------------------
*
* Tcl_PwdObjCmd --
*
* This procedure is invoked to process the "pwd" Tcl command.
* See the user documentation for details on what it does.
| > > > > | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static void TraceCommandProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *oldName,
CONST char *newName, int flags));
static Tcl_CmdObjTraceProc TraceExecutionProc;
#ifdef TCL_TIP280
static void ListLines _ANSI_ARGS_((CONST char* listStr, int line,
int n, int* lines));
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_PwdObjCmd --
*
* This procedure is invoked to process the "pwd" Tcl command.
* See the user documentation for details on what it does.
|
| ︙ | ︙ | |||
364 365 366 367 368 369 370 |
* hasn't been specified then the loop body only gets executed once.
* We terminate the loop when the starting offset is past the end of the
* string.
*/
while (1) {
match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
| | > > > | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
* hasn't been specified then the loop body only gets executed once.
* We terminate the loop when the starting offset is past the end of the
* string.
*/
while (1) {
match = Tcl_RegExpExecObj(interp, regExpr, objPtr,
offset /* offset */, numMatchesSaved, eflags
| ((offset > 0 &&
(Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n'))
? TCL_REG_NOTBOL : 0));
if (match < 0) {
return TCL_ERROR;
}
if (match == 0) {
/*
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 460 |
if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
!= TCL_OK) {
Tcl_DecrRefCount(newPtr);
return TCL_ERROR;
}
} else {
Tcl_Obj *valuePtr;
valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
| > < | > | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 |
if (Tcl_ListObjAppendElement(interp, resultPtr, newPtr)
!= TCL_OK) {
Tcl_DecrRefCount(newPtr);
return TCL_ERROR;
}
} else {
Tcl_Obj *valuePtr;
Tcl_IncrRefCount(newPtr);
valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
Tcl_DecrRefCount(newPtr);
if (valuePtr == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
Tcl_GetString(objv[i]), "\"", (char *) NULL);
return TCL_ERROR;
}
}
}
|
| ︙ | ︙ | |||
715 716 717 718 719 720 721 |
result = TCL_OK;
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match and its
* corresponding substitution. If "-all" hasn't been specified
| | > > > | | > > | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 |
result = TCL_OK;
/*
* The following loop is to handle multiple matches within the
* same source string; each iteration handles one match and its
* corresponding substitution. If "-all" hasn't been specified
* then the loop body only gets executed once. We must use
* 'offset <= wlen' in particular for the case where the regexp
* pattern can match the empty string - this is useful when
* doing, say, 'regsub -- ^ $str ...' when $str might be empty.
*/
numMatches = 0;
for ( ; offset <= wlen; ) {
/*
* The flags argument is set if string is part of a larger string,
* so that "^" won't match.
*/
match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset,
10 /* matches */, ((offset > 0 &&
(wstring[offset-1] != (Tcl_UniChar)'\n'))
? TCL_REG_NOTBOL : 0));
if (match < 0) {
result = TCL_ERROR;
goto done;
}
if (match == 0) {
break;
|
| ︙ | ︙ | |||
815 816 817 818 819 820 821 |
}
if (end == 0) {
/*
* Always consume at least one character of the input string
* in order to prevent infinite loops.
*/
| > | > > > > > > > > > > > > | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 |
}
if (end == 0) {
/*
* Always consume at least one character of the input string
* in order to prevent infinite loops.
*/
if (offset < wlen) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
} else {
offset += end;
if (start == end) {
/*
* We matched an empty string, which means we must go
* forward one more step so we don't match again at the
* same spot.
*/
if (offset < wlen) {
Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1);
}
offset++;
}
}
if (!all) {
break;
}
}
/*
|
| ︙ | ︙ | |||
1566 1567 1568 1569 1570 1571 1572 | break; } } break; case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: | < | < < < < < | | 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 |
break;
}
}
break;
case STR_IS_BOOL:
case STR_IS_TRUE:
case STR_IS_FALSE:
/* Optimizers, beware Bug 1187123 ! */
if ((Tcl_GetBoolean(NULL, string1, &i)
== TCL_ERROR) ||
(((enum isOptions) index == STR_IS_TRUE) &&
i == 0) ||
(((enum isOptions) index == STR_IS_FALSE) &&
i != 0)) {
result = 0;
}
|
| ︙ | ︙ | |||
1655 1656 1657 1658 1659 1660 1661 1662 |
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT: {
char *stop;
| > < | > | < | < < < | > | 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
break;
}
case STR_IS_GRAPH:
chcomp = Tcl_UniCharIsGraph;
break;
case STR_IS_INT: {
char *stop;
long int l = 0;
if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
break;
}
/*
* Like STR_IS_DOUBLE, but we use strtoul.
* Since Tcl_GetIntFromObj already failed,
* we set result to 0.
*/
result = 0;
errno = 0;
l = strtol(string1, &stop, 0); /* INTL: Tcl source. */
if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) {
/*
* if (errno == ERANGE), then it was an over/underflow
* problem, but in this method, we only want to know
* yes or no, so bad flow returns 0 (false) and sets
* the failVarObj to the string length.
*/
failat = -1;
} else if (stop == string1) {
/*
* In this case, nothing like a number was found
*/
failat = 0;
} else {
/*
|
| ︙ | ︙ | |||
1740 1741 1742 1743 1744 1745 1746 | } } str_is_done: /* * Only set the failVarObj when we will return 0 * and we have indicated a valid fail index (>= 0) */ | | > > > | | > > | > | 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 |
}
}
str_is_done:
/*
* Only set the failVarObj when we will return 0
* and we have indicated a valid fail index (>= 0)
*/
if ((result == 0) && (failVarObj != NULL)) {
Tcl_Obj *resPtr, *tmpPtr = Tcl_NewIntObj(failat);
Tcl_IncrRefCount(tmpPtr);
resPtr = Tcl_ObjSetVar2(interp, failVarObj, NULL, tmpPtr,
TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(tmpPtr);
if (resPtr == NULL) {
return TCL_ERROR;
}
}
Tcl_SetBooleanObj(resultPtr, result);
break;
}
case STR_LAST: {
Tcl_UniChar *ustring1, *ustring2, *p;
int match, start;
|
| ︙ | ︙ | |||
1834 1835 1836 1837 1838 1839 1840 |
length1 = Tcl_GetCharLength(objv[2]);
}
}
Tcl_SetIntObj(resultPtr, length1);
break;
}
case STR_MAP: {
| | | | 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 |
length1 = Tcl_GetCharLength(objv[2]);
}
}
Tcl_SetIntObj(resultPtr, length1);
break;
}
case STR_MAP: {
int mapElemc, nocase = 0, copySource = 0;
Tcl_Obj **mapElemv, *sourceObj;
Tcl_UniChar *ustring1, *ustring2, *p, *end;
int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*,
CONST Tcl_UniChar*, unsigned long));
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1875 1876 1877 1878 1879 1880 1881 |
} else if (mapElemc & 1) {
/*
* The charMap must be an even number of key/value items
*/
Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
return TCL_ERROR;
}
| | > > > > > > > > > > | | > > > | 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 |
} else if (mapElemc & 1) {
/*
* The charMap must be an even number of key/value items
*/
Tcl_SetStringObj(resultPtr, "char map list unbalanced", -1);
return TCL_ERROR;
}
/*
* Take a copy of the source string object if it is the
* same as the map string to cut out nasty sharing
* crashes. [Bug 1018562]
*/
if (objv[objc-2] == objv[objc-1]) {
sourceObj = Tcl_DuplicateObj(objv[objc-1]);
copySource = 1;
} else {
sourceObj = objv[objc-1];
}
ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now
*/
if (copySource) {
Tcl_DecrRefCount(sourceObj);
}
break;
}
end = ustring1 + length1;
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
/*
|
| ︙ | ︙ | |||
1905 1906 1907 1908 1909 1910 1911 | * This will be >30% faster on larger strings. */ int mapLen; Tcl_UniChar *mapString, u2lc; ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; | | > | 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 |
* This will be >30% faster on larger strings.
*/
int mapLen;
Tcl_UniChar *mapString, u2lc;
ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
p = ustring1;
if ((length2 > length1) || (length2 == 0)) {
/* match string is either longer than input or empty */
ustring1 = end;
} else {
mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
for (; ustring1 < end; ustring1++) {
if (((*ustring1 == *ustring2) ||
(nocase && (Tcl_UniCharToLower(*ustring1) ==
|
| ︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 |
* Get the key string to match on.
*/
ustring2 = mapStrings[index];
length2 = mapLens[index];
if ((length2 > 0) && ((*ustring1 == *ustring2) ||
(nocase && (Tcl_UniCharToLower(*ustring1) ==
u2lc[index/2]))) &&
((length2 == 1) || strCmpFn(ustring2, ustring1,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
/*
* Put the skipped chars onto the result first
*/
Tcl_AppendUnicodeToObj(resultPtr, p,
| > > | 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 |
* Get the key string to match on.
*/
ustring2 = mapStrings[index];
length2 = mapLens[index];
if ((length2 > 0) && ((*ustring1 == *ustring2) ||
(nocase && (Tcl_UniCharToLower(*ustring1) ==
u2lc[index/2]))) &&
/* restrict max compare length */
((end - ustring1) >= length2) &&
((length2 == 1) || strCmpFn(ustring2, ustring1,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
/*
* Put the skipped chars onto the result first
*/
Tcl_AppendUnicodeToObj(resultPtr, p,
|
| ︙ | ︙ | |||
2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 |
}
if (p != ustring1) {
/*
* Put the rest of the unmapped chars onto result
*/
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
break;
}
case STR_MATCH: {
Tcl_UniChar *ustring1, *ustring2;
int nocase = 0;
if (objc < 4 || objc > 5) {
| > > > | 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 |
}
if (p != ustring1) {
/*
* Put the rest of the unmapped chars onto result
*/
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
}
if (copySource) {
Tcl_DecrRefCount(sourceObj);
}
break;
}
case STR_MATCH: {
Tcl_UniChar *ustring1, *ustring2;
int nocase = 0;
if (objc < 4 || objc > 5) {
|
| ︙ | ︙ | |||
2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 |
} else if (count > 1) {
string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (length1 > 0) {
/*
* Only build up a string that has data. Instead of
* building it up with repeated appends, we just allocate
* the necessary space once and copy the string value in.
*/
length2 = length1 * count;
/*
* Include space for the NULL
*/
string2 = (char *) ckalloc((size_t) length2+1);
for (index = 0; index < count; index++) {
memcpy(string2 + (length1 * index), string1,
(size_t) length1);
| > > > > > > > > > | 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 |
} else if (count > 1) {
string1 = Tcl_GetStringFromObj(objv[2], &length1);
if (length1 > 0) {
/*
* Only build up a string that has data. Instead of
* building it up with repeated appends, we just allocate
* the necessary space once and copy the string value in.
* Check for overflow with back-division. [Bug #714106]
*/
length2 = length1 * count;
if ((length2 / count) != length1) {
char buf[TCL_INTEGER_SPACE+1];
sprintf(buf, "%d", INT_MAX);
Tcl_AppendStringsToObj(resultPtr,
"string size overflow, must be less than ",
buf, (char *) NULL);
return TCL_ERROR;
}
/*
* Include space for the NULL
*/
string2 = (char *) ckalloc((size_t) length2+1);
for (index = 0; index < count; index++) {
memcpy(string2 + (length1 * index), string1,
(size_t) length1);
|
| ︙ | ︙ | |||
2522 2523 2524 2525 2526 2527 2528 2529 |
Tcl_SubstObj(interp, objPtr, flags)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
int flags;
{
Tcl_Obj *resultObj;
char *p, *old;
| > | | < < < < < < | | | 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 |
Tcl_SubstObj(interp, objPtr, flags)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
int flags;
{
Tcl_Obj *resultObj;
char *p, *old;
int length;
old = p = Tcl_GetStringFromObj(objPtr, &length);
resultObj = Tcl_NewStringObj("", 0);
while (length) {
switch (*p) {
case '\\':
if (flags & TCL_SUBST_BACKSLASHES) {
char buf[TCL_UTF_MAX];
int count;
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
Tcl_AppendToObj(resultObj, buf,
Tcl_UtfBackslash(p, &count, buf));
p += count; length -= count;
old = p;
} else {
p++; length--;
}
break;
case '$':
if (flags & TCL_SUBST_VARIABLES) {
Tcl_Parse parse;
int code;
|
| ︙ | ︙ | |||
2573 2574 2575 2576 2577 2578 2579 |
goto errorResult;
}
if (parse.numTokens == 1) {
/*
* There isn't a variable name after all: the $ is
* just a $.
*/
| | > | > > > | > > > | | > > > > | 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 |
goto errorResult;
}
if (parse.numTokens == 1) {
/*
* There isn't a variable name after all: the $ is
* just a $.
*/
p++; length--;
break;
}
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
p += parse.tokenPtr->size;
length -= parse.tokenPtr->size;
code = Tcl_EvalTokensStandard(interp, parse.tokenPtr,
parse.numTokens);
if (code == TCL_ERROR) {
goto errorResult;
}
if (code == TCL_BREAK) {
Tcl_ResetResult(interp);
return resultObj;
}
if (code != TCL_CONTINUE) {
Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
}
Tcl_ResetResult(interp);
old = p;
} else {
p++; length--;
}
break;
case '[':
if (flags & TCL_SUBST_COMMANDS) {
Interp *iPtr = (Interp *) interp;
int code;
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
iPtr->evalFlags = TCL_BRACKET_TERM;
iPtr->numLevels++;
code = TclInterpReady(interp);
if (code == TCL_OK) {
code = Tcl_EvalEx(interp, p+1, -1, 0);
}
iPtr->numLevels--;
switch (code) {
case TCL_ERROR:
goto errorResult;
case TCL_BREAK:
Tcl_ResetResult(interp);
return resultObj;
default:
Tcl_AppendObjToObj(resultObj, Tcl_GetObjResult(interp));
case TCL_CONTINUE:
Tcl_ResetResult(interp);
old = p = (p+1 + iPtr->termOffset + 1);
length -= (iPtr->termOffset + 2);
}
} else {
p++; length--;
}
break;
default:
p++; length--;
break;
}
}
if (p != old) {
Tcl_AppendToObj(resultObj, old, p-old);
}
return resultObj;
errorResult:
Tcl_DecrRefCount(resultObj);
return NULL;
}
/*
|
| ︙ | ︙ | |||
2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 |
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, j, index, mode, matched, result, splitObjs;
char *string, *pattern;
Tcl_Obj *stringObj;
Tcl_Obj *CONST *savedObjv = objv;
static CONST char *options[] = {
"-exact", "-glob", "-regexp", "--",
NULL
};
enum options {
OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST
};
| > > > > > > > > > | 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 |
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int i, j, index, mode, matched, result, splitObjs;
char *string, *pattern;
Tcl_Obj *stringObj;
Tcl_Obj *CONST *savedObjv = objv;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
int pc = 0;
int bidx = 0; /* Index of body argument */
Tcl_Obj* blist = NULL; /* List obj which is the body */
CmdFrame ctx; /* Copy of the topmost cmdframe,
* to allow us to mess with the
* line information */
#endif
static CONST char *options[] = {
"-exact", "-glob", "-regexp", "--",
NULL
};
enum options {
OPT_EXACT, OPT_GLOB, OPT_REGEXP, OPT_LAST
};
|
| ︙ | ︙ | |||
2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 |
"?switches? string pattern body ... ?default body?");
return TCL_ERROR;
}
stringObj = objv[i];
objc -= i + 1;
objv += i + 1;
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
| > > > > > > > | > > | 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 |
"?switches? string pattern body ... ?default body?");
return TCL_ERROR;
}
stringObj = objv[i];
objc -= i + 1;
objv += i + 1;
#ifdef TCL_TIP280
bidx = i+1; /* First after the match string */
#endif
/*
* If all of the pattern/command pairs are lumped into a single
* argument, split them out again.
*
* TIP #280: Determine the lines the words in the list start at, based on
* the same data for the list word itself. The cmdFramePtr line information
* is manipulated directly.
*/
splitObjs = 0;
if (objc == 1) {
Tcl_Obj **listv;
#ifdef TCL_TIP280
blist = objv[0];
#endif
if (Tcl_ListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Ensure that the list is non-empty.
*/
|
| ︙ | ︙ | |||
2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 |
if (matched == 0) {
continue;
}
/*
* We've got a match. Find a body to execute, skipping bodies
* that are "-".
*/
for (j = i + 1; ; j += 2) {
if (j >= objc) {
/*
* This shouldn't happen since we've checked that the
* last body is not a continuation...
*/
panic("fall-out when searching for body to match pattern");
}
if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
break;
}
}
result = Tcl_EvalObjEx(interp, objv[j], 0);
if (result == TCL_ERROR) {
char msg[100 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 |
if (matched == 0) {
continue;
}
/*
* We've got a match. Find a body to execute, skipping bodies
* that are "-".
*
* TIP#280: Now is also the time to determine a line number for the
* single-word case.
*/
#ifdef TCL_TIP280
ctx = *iPtr->cmdFramePtr;
if (splitObjs) {
/* We have to perform the GetSrc and other type dependent handling
* of the frame here because we are munging with the line numbers,
* something the other commands like if, etc. are not doing. Them
* are fine with simply passing the CmdFrame through and having
* the special handling done in 'info frame', or the bc compiler
*/
if (ctx.type == TCL_LOCATION_BC) {
/* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc (&ctx);
pc = 1;
/* The line information in the cmdFrame is now a copy we do
* not own */
}
if (ctx.type == TCL_LOCATION_SOURCE) {
int bline = ctx.line [bidx];
if (bline >= 0) {
ctx.line = (int*) ckalloc (objc * sizeof(int));
ctx.nline = objc;
ListLines (Tcl_GetString (blist), bline, objc, ctx.line);
} else {
int k;
/* Dynamic code word ... All elements are relative to themselves */
ctx.line = (int*) ckalloc (objc * sizeof(int));
ctx.nline = objc;
for (k=0; k < objc; k++) {ctx.line[k] = -1;}
}
} else {
int k;
/* Anything else ... No information, or dynamic ... */
ctx.line = (int*) ckalloc (objc * sizeof(int));
ctx.nline = objc;
for (k=0; k < objc; k++) {ctx.line[k] = -1;}
}
}
#endif
for (j = i + 1; ; j += 2) {
if (j >= objc) {
/*
* This shouldn't happen since we've checked that the
* last body is not a continuation...
*/
panic("fall-out when searching for body to match pattern");
}
if (strcmp(Tcl_GetString(objv[j]), "-") != 0) {
break;
}
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[j], 0);
#else
/* TIP #280. Make invoking context available to switch branch */
result = TclEvalObjEx(interp, objv[j], 0, &ctx, j);
if (splitObjs) {
ckfree ((char*) ctx.line);
if (pc && (ctx.type == TCL_LOCATION_SOURCE)) {
/* Death of SrcInfo reference */
Tcl_DecrRefCount (ctx.data.eval.path);
}
}
#endif
if (result == TCL_ERROR) {
char msg[100 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"%.50s\" arm line %d)", pattern,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
}
|
| ︙ | ︙ | |||
2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 |
Tcl_TimeObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *objPtr;
register int i, result;
int count;
double totalMicroSec;
Tcl_Time start, stop;
| > < | 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 |
Tcl_TimeObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Tcl_Obj *objPtr;
Tcl_Obj *objs[4];
register int i, result;
int count;
double totalMicroSec;
Tcl_Time start, stop;
if (objc == 2) {
count = 1;
} else if (objc == 3) {
result = Tcl_GetIntFromObj(interp, objv[2], &count);
if (result != TCL_OK) {
return result;
|
| ︙ | ︙ | |||
2891 2892 2893 2894 2895 2896 2897 |
return result;
}
}
Tcl_GetTime(&stop);
totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6
+ ( stop.usec - start.usec ) );
| | > > > | > > | > | | 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 |
return result;
}
}
Tcl_GetTime(&stop);
totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6
+ ( stop.usec - start.usec ) );
if (count <= 1) {
/* Use int obj since we know time is not fractional [Bug 1202178] */
objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec);
} else {
objs[0] = Tcl_NewDoubleObj(totalMicroSec/count);
}
objs[1] = Tcl_NewStringObj("microseconds", -1);
objs[2] = Tcl_NewStringObj("per", -1);
objs[3] = Tcl_NewStringObj("iteration", -1);
Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TraceObjCmd --
|
| ︙ | ︙ | |||
2927 2928 2929 2930 2931 2932 2933 |
int
Tcl_TraceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
| | | < | 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 |
int
Tcl_TraceObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int optionIndex;
char *name, *flagOps, *p;
/* Main sub commands to 'trace' */
static CONST char *traceOptions[] = {
"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
#endif
(char *) NULL
|
| ︙ | ︙ | |||
2974 2975 2976 2977 2978 2979 2980 |
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
"option", 0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
| < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > | < < | > | > > > > < > > < > > < < < < < < < | < < < | < < | | < > > > > | < < < < < < < < < < < < < < < | > > > > > > > > | | 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 |
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], traceTypeOptions,
"option", 0, &typeIndex) != TCL_OK) {
return TCL_ERROR;
}
return (traceSubCmds[typeIndex])(interp, optionIndex, objc, objv);
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE:
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
int code, numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
opsList = Tcl_NewObj();
Tcl_IncrRefCount(opsList);
flagOps = Tcl_GetStringFromObj(objv[3], &numFlags);
if (numFlags == 0) {
Tcl_DecrRefCount(opsList);
goto badVarOps;
}
for (p = flagOps; *p != 0; p++) {
if (*p == 'r') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("read", -1));
} else if (*p == 'w') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("write", -1));
} else if (*p == 'u') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("unset", -1));
} else if (*p == 'a') {
Tcl_ListObjAppendElement(NULL, opsList,
Tcl_NewStringObj("array", -1));
} else {
Tcl_DecrRefCount(opsList);
goto badVarOps;
}
}
copyObjv[0] = NULL;
memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *));
copyObjv[4] = opsList;
if (optionIndex == TRACE_OLD_VARIABLE) {
code = (traceSubCmds[2])(interp,TRACE_ADD,objc+1,copyObjv);
} else {
code = (traceSubCmds[2])(interp,TRACE_REMOVE,objc+1,copyObjv);
}
Tcl_DecrRefCount(opsList);
return code;
}
case TRACE_OLD_VINFO: {
ClientData clientData;
char ops[5];
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
|
| ︙ | ︙ | |||
3236 3237 3238 3239 3240 3241 3242 | tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; tcmdPtr->startLevel = 0; tcmdPtr->startCmd = NULL; tcmdPtr->length = length; tcmdPtr->refCount = 1; flags |= TCL_TRACE_DELETE; | | > | > | 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 |
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC |
TCL_TRACE_LEAVE_EXEC);
}
strcpy(tcmdPtr->command, command);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
(ClientData) tcmdPtr) != TCL_OK) {
ckfree((char *) tcmdPtr);
return TCL_ERROR;
|
| ︙ | ︙ | |||
3278 3279 3280 3281 3282 3283 3284 |
if ((tcmdPtr->length == length)
&& ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC |
TCL_TRACE_RENAME |
TCL_TRACE_DELETE)) == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
flags |= TCL_TRACE_DELETE;
| | | | > > > > | 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 |
if ((tcmdPtr->length == length)
&& ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC |
TCL_TRACE_RENAME |
TCL_TRACE_DELETE)) == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC |
TCL_TRACE_LEAVE_EXEC);
}
Tcl_UntraceCommand(interp, name,
flags, TraceCommandProc, clientData);
if (tcmdPtr->stepTrace != NULL) {
/*
* We need to remove the interpreter-wide trace
* which we created to allow 'step' traces.
*/
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/* Postpone deletion */
tcmdPtr->flags = 0;
}
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TclTraceExecutionObjCmd: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
break;
}
}
}
break;
|
| ︙ | ︙ | |||
3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 |
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
| > < < > > > > > > > > | 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 |
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
int numOps = 0;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
/*
* Build a list with the ops list as the first obj
* element and the tcmdPtr->command string as the
* second obj element. Append this list (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_IncrRefCount(elemObjPtr);
if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("enter",5));
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("leave",5));
}
if (tcmdPtr->flags & TCL_TRACE_ENTER_DURING_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("enterstep",9));
}
if (tcmdPtr->flags & TCL_TRACE_LEAVE_DURING_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("leavestep",9));
}
Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
elemObjPtr = NULL;
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr,
Tcl_NewStringObj(tcmdPtr->command, -1));
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
|
| ︙ | ︙ | |||
3495 3496 3497 3498 3499 3500 3501 |
&& (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceCommand(interp, name,
flags | TCL_TRACE_DELETE,
TraceCommandProc, clientData);
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
| | > > > > | 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 |
&& (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceCommand(interp, name,
flags | TCL_TRACE_DELETE,
TraceCommandProc, clientData);
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TclTraceCommandObjCmd: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char *) tcmdPtr);
}
break;
}
}
}
break;
|
| ︙ | ︙ | |||
3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 |
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
| > < < > > > > > > > > | 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 |
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != NULL) {
int numOps = 0;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
/*
* Build a list with the ops list as
* the first obj element and the tcmdPtr->command string
* as the second obj element. Append this list (as an
* element) to the end of the result object list.
*/
elemObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_IncrRefCount(elemObjPtr);
if (tcmdPtr->flags & TCL_TRACE_RENAME) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("rename",6));
}
if (tcmdPtr->flags & TCL_TRACE_DELETE) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("delete",6));
}
Tcl_ListObjLength(NULL, elemObjPtr, &numOps);
if (0 == numOps) {
Tcl_DecrRefCount(elemObjPtr);
continue;
}
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_DecrRefCount(elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
|
| ︙ | ︙ | |||
3644 3645 3646 3647 3648 3649 3650 3651 |
flags |= TCL_TRACE_WRITES;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceVarInfo *tvarPtr;
| > > > > > > > > > > > > | | > > > > > > | > > | | > > > > > > > > > > > | < | 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 |
flags |= TCL_TRACE_WRITES;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
/*
* This code essentially mallocs together the VarTrace and the
* TraceVarInfo, then inlines the Tcl_TraceVar(). This is
* necessary in order to have the TraceVarInfo to be freed
* automatically when the VarTrace is freed [Bug 1348775]
*/
CompoundVarTrace *compTracePtr;
TraceVarInfo *tvarPtr;
Var *varPtr, *arrayPtr;
VarTrace *tracePtr;
int flagMask;
compTracePtr = (CompoundVarTrace *) ckalloc((unsigned)
(sizeof(CompoundVarTrace) - sizeof(tvarPtr->command)
+ length + 1));
tracePtr = &(compTracePtr->trace);
tvarPtr = &(compTracePtr->tvar);
tvarPtr->flags = flags;
if (objv[0] == NULL) {
tvarPtr->flags |= TCL_TRACE_OLD_STYLE;
}
tvarPtr->length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
strcpy(tvarPtr->command, command);
name = Tcl_GetString(objv[3]);
flagMask = TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY;
varPtr = TclLookupVar(interp, name, NULL,
(flags & flagMask) | TCL_LEAVE_ERR_MSG, "trace",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
ckfree((char *) tracePtr);
return TCL_ERROR;
}
flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES
| TCL_TRACE_UNSETS | TCL_TRACE_ARRAY
| TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
tracePtr->traceProc = TraceVarProc;
tracePtr->clientData = (ClientData) tvarPtr;
tracePtr->flags = flags & flagMask;
tracePtr->nextPtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr;
} else {
/*
* Search through all of our traces on this variable to
* see if there's one with the given command. If so, then
* delete the first one that matches.
*/
TraceVarInfo *tvarPtr;
ClientData clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
tvarPtr = (TraceVarInfo *) clientData;
if ((tvarPtr->length == length)
&& ((tvarPtr->flags & ~TCL_TRACE_OLD_STYLE)==flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
break;
}
}
}
break;
}
case TRACE_INFO: {
|
| ︙ | ︙ | |||
3701 3702 3703 3704 3705 3706 3707 |
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
| < | 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 |
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_VarTraceInfo(interp, name, 0,
TraceVarProc, clientData)) != 0) {
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
/*
* Build a list with the ops list as
* the first obj element and the tcmdPtr->command string
* as the second obj element. Append this list (as an
* element) to the end of the result object list.
*/
|
| ︙ | ︙ | |||
3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 |
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("write", 5));
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("unset", 5));
}
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
| > | 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 |
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("write", 5));
}
if (tvarPtr->flags & TCL_TRACE_UNSETS) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("unset", 5));
}
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
|
| ︙ | ︙ | |||
3942 3943 3944 3945 3946 3947 3948 |
* are active: it makes sure that the deleted trace won't be
* processed by CallCommandTraces.
*/
for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
| > > > | > | 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 |
* are active: it makes sure that the deleted trace won't be
* processed by CallCommandTraces.
*/
for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
if (activePtr->reverseScan) {
activePtr->nextTracePtr = prevPtr;
} else {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
}
if (prevPtr == NULL) {
cmdPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
|
| ︙ | ︙ | |||
4010 4011 4012 4013 4014 4015 4016 |
Tcl_SavedResult state;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
int code;
Tcl_DString cmd;
tcmdPtr->refCount++;
| | | 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 |
Tcl_SavedResult state;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
int code;
Tcl_DString cmd;
tcmdPtr->refCount++;
if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)) {
/*
* Generate a command to execute by appending list elements
* for the old and new command name and the operation.
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
|
| ︙ | ︙ | |||
4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 |
Tcl_DStringFree(&cmd);
}
/*
* We delete when the trace was destroyed or if this is a delete trace,
* because command deletes are unconditional, so the trace must go away.
*/
if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/* Postpone deletion, until exec trace returns */
tcmdPtr->flags = 0;
}
| > > > | > > > > > | > > > > > > > > > | > > > > > > > > > > > > > > > | > > > > | 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 |
Tcl_DStringFree(&cmd);
}
/*
* We delete when the trace was destroyed or if this is a delete trace,
* because command deletes are unconditional, so the trace must go away.
*/
if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
int untraceFlags = tcmdPtr->flags;
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/* Postpone deletion, until exec trace returns */
tcmdPtr->flags = 0;
}
/*
* We need to construct the same flags for Tcl_UntraceCommand
* as were passed to Tcl_TraceCommand. Reproduce the processing
* of [trace add execution/command]. Be careful to keep this
* code in sync with that.
*/
if (untraceFlags & TCL_TRACE_ANY_EXEC) {
untraceFlags |= TCL_TRACE_DELETE;
if (untraceFlags & (TCL_TRACE_ENTER_DURING_EXEC
| TCL_TRACE_LEAVE_DURING_EXEC)) {
untraceFlags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
} else if (untraceFlags & TCL_TRACE_RENAME) {
untraceFlags |= TCL_TRACE_DELETE;
}
/*
* Remove the trace since TCL_TRACE_DESTROYED tells us to, or the
* command we're tracing has just gone away. Then decrement the
* clientData refCount that was set up by trace creation.
*
* Note that we save the (return) state of the interpreter to prevent
* bizarre error messages.
*/
Tcl_SaveResult(interp, &state);
stateCode = iPtr->returnCode;
Tcl_UntraceCommand(interp, oldName, untraceFlags,
TraceCommandProc, clientData);
Tcl_RestoreResult(interp, &state);
iPtr->returnCode = stateCode;
tcmdPtr->refCount--;
}
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TraceCommandProc: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
return;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 |
active.cmdPtr = cmdPtr;
lastTracePtr = NULL;
for (tracePtr = cmdPtr->tracePtr;
(traceCode == TCL_OK) && (tracePtr != NULL);
tracePtr = active.nextTracePtr) {
if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
/* execute the trace command in order of creation for "leave" */
active.nextTracePtr = NULL;
tracePtr = cmdPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
} else {
active.nextTracePtr = tracePtr->nextPtr;
}
| > > > | | | | | | | | > > > > | | | > > | > | 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 |
active.cmdPtr = cmdPtr;
lastTracePtr = NULL;
for (tracePtr = cmdPtr->tracePtr;
(traceCode == TCL_OK) && (tracePtr != NULL);
tracePtr = active.nextTracePtr) {
if (traceFlags & TCL_TRACE_LEAVE_EXEC) {
/* execute the trace command in order of creation for "leave" */
active.reverseScan = 1;
active.nextTracePtr = NULL;
tracePtr = cmdPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->traceProc == TraceCommandProc) {
tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
if (tcmdPtr->flags != 0) {
tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
tcmdPtr->curCode = code;
tcmdPtr->refCount++;
traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TclCheckExecutionTraces: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
}
}
if (active.nextTracePtr) {
lastTracePtr = active.nextTracePtr->nextPtr;
}
}
iPtr->activeCmdTracePtr = active.nextPtr;
return(traceCode);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4211 4212 4213 4214 4215 4216 4217 |
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
Trace *tracePtr, *lastTracePtr;
ActiveInterpTrace active;
int curLevel;
int traceCode = TCL_OK;
| < | > > < | > > | | | > | < < | | > | > | 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 |
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
Trace *tracePtr, *lastTracePtr;
ActiveInterpTrace active;
int curLevel;
int traceCode = TCL_OK;
if (command == NULL || iPtr->tracePtr == NULL ||
(iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
return(traceCode);
}
curLevel = iPtr->numLevels;
active.nextPtr = iPtr->activeInterpTracePtr;
iPtr->activeInterpTracePtr = &active;
lastTracePtr = NULL;
for ( tracePtr = iPtr->tracePtr;
(traceCode == TCL_OK) && (tracePtr != NULL);
tracePtr = active.nextTracePtr) {
if (traceFlags & TCL_TRACE_ENTER_EXEC) {
/*
* Execute the trace command in reverse order of creation
* for "enterstep" operation. The order is changed for
* "enterstep" instead of for "leavestep" as was done in
* TclCheckExecutionTraces because for step traces,
* Tcl_CreateObjTrace creates one more linked list of traces
* which results in one more reversal of trace invocation.
*/
active.reverseScan = 1;
active.nextTracePtr = NULL;
tracePtr = iPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->level > 0 && curLevel > tracePtr->level) {
continue;
}
if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
/*
* The proc invoked might delete the traced command which
* which might try to free tracePtr. We want to use tracePtr
* until the end of this if section, so we use
* Tcl_Preserve() and Tcl_Release() to be sure it is not
* freed while we still need it.
*/
Tcl_Preserve((ClientData) tracePtr);
tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
if (tracePtr->flags & (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {
/* New style trace */
if (tracePtr->flags & traceFlags) {
if (tracePtr->proc == TraceExecutionProc) {
TraceCommandInfo *tcmdPtr =
(TraceCommandInfo *) tracePtr->clientData;
tcmdPtr->curFlags = traceFlags;
tcmdPtr->curCode = code;
}
traceCode = (tracePtr->proc)(tracePtr->clientData,
interp, curLevel, command, (Tcl_Command)cmdPtr,
objc, objv);
}
} else {
/* Old-style trace */
if (traceFlags & TCL_TRACE_ENTER_EXEC) {
/*
* Old-style interpreter-wide traces only trigger
* before the command is executed.
*/
traceCode = CallTraceProcedure(interp, tracePtr, cmdPtr,
command, numChars, objc, objv);
}
}
tracePtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
Tcl_Release((ClientData) tracePtr);
}
if (active.nextTracePtr) {
lastTracePtr = active.nextTracePtr->nextPtr;
}
}
iPtr->activeInterpTracePtr = active.nextPtr;
return(traceCode);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4367 4368 4369 4370 4371 4372 4373 |
* May release memory.
*
*----------------------------------------------------------------------
*/
static void
CommandObjTraceDeleted(ClientData clientData) {
TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
| | > > > > | | 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 |
* May release memory.
*
*----------------------------------------------------------------------
*/
static void
CommandObjTraceDeleted(ClientData clientData) {
TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("CommandObjTraceDeleted: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TraceExecutionProc --
|
| ︙ | ︙ | |||
4417 4418 4419 4420 4421 4422 4423 |
* Inside any kind of execution trace callback, we do
* not allow any further execution trace callbacks to
* be called for the same trace.
*/
return traceCode;
}
| | | | | 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 |
* Inside any kind of execution trace callback, we do
* not allow any further execution trace callbacks to
* be called for the same trace.
*/
return traceCode;
}
if (!Tcl_InterpDeleted(interp)) {
/*
* Check whether the current call is going to eval arbitrary
* Tcl code with a generated trace, or whether we are only
* going to setup interpreter-wide traces to implement the
* 'step' traces. This latter situation can happen if
* we create a command trace without either before or after
* operations, but with either of the step operations.
*/
if (flags & TCL_TRACE_EXEC_DIRECT) {
call = flags & tcmdPtr->flags
& (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
} else {
call = 1;
}
/*
* First, if we have returned back to the level at which we
* created an interpreter trace for enterstep and/or leavestep
* execution traces, we remove it here.
|
| ︙ | ︙ | |||
4453 4454 4455 4456 4457 4458 4459 |
}
/*
* Second, create the tcl callback, if required.
*/
if (call) {
Tcl_SavedResult state;
| | < | 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 |
}
/*
* Second, create the tcl callback, if required.
*/
if (call) {
Tcl_SavedResult state;
int stateCode, i, saveInterpFlags;
Tcl_DString cmd;
Tcl_DString sub;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);
/* Append command with arguments */
Tcl_DStringInit(&sub);
for (i = 0; i < objc; i++) {
char* str;
|
| ︙ | ︙ | |||
4510 4511 4512 4513 4514 4515 4516 | * may be modified when Tcl_Eval is invoked. We discard any * object result the command returns. */ Tcl_SaveResult(interp, &state); stateCode = iPtr->returnCode; | | > | > > > > > > > | | 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 |
* may be modified when Tcl_Eval is invoked. We discard any
* object result the command returns.
*/
Tcl_SaveResult(interp, &state);
stateCode = iPtr->returnCode;
saveInterpFlags = iPtr->flags;
iPtr->flags |= INTERP_TRACE_IN_PROGRESS;
tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
tcmdPtr->refCount++;
/*
* This line can have quite arbitrary side-effects,
* including deleting the trace, the command being
* traced, or even the interpreter.
*/
traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
/*
* Restore the interp tracing flag to prevent cmd traces
* from affecting interp traces
*/
iPtr->flags = saveInterpFlags;;
if (tcmdPtr->flags == 0) {
flags |= TCL_TRACE_DESTROYED;
}
if (traceCode == TCL_OK) {
/* Restore result if trace execution was successful */
Tcl_RestoreResult(interp, &state);
iPtr->returnCode = stateCode;
} else {
Tcl_DiscardResult(&state);
}
Tcl_DStringFree(&cmd);
}
/*
* Third, if there are any step execution traces for this proc,
* we register an interpreter trace to invoke enterstep and/or
|
| ︙ | ︙ | |||
4566 4567 4568 4569 4570 4571 4572 |
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
}
if (call) {
| | > > > > | 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 |
tcmdPtr->stepTrace = NULL;
if (tcmdPtr->startCmd != NULL) {
ckfree((char *)tcmdPtr->startCmd);
}
}
}
if (call) {
tcmdPtr->refCount--;
if (tcmdPtr->refCount < 0) {
Tcl_Panic("TraceExecutionProc: negative TraceCommandInfo refCount");
}
if (tcmdPtr->refCount == 0) {
ckfree((char*)tcmdPtr);
}
}
return traceCode;
}
/*
|
| ︙ | ︙ | |||
4605 4606 4607 4608 4609 4610 4611 |
* scalar variable is being referenced. */
int flags; /* OR-ed bits giving operation and other
* information. */
{
Tcl_SavedResult state;
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
char *result;
| | | | < < | > < < | | 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 |
* scalar variable is being referenced. */
int flags; /* OR-ed bits giving operation and other
* information. */
{
Tcl_SavedResult state;
TraceVarInfo *tvarPtr = (TraceVarInfo *) clientData;
char *result;
int code, destroy = 0;
Tcl_DString cmd;
/*
* We might call Tcl_Eval() below, and that might evaluate [trace
* vdelete] which might try to free tvarPtr. However we do not
* need to protect anything here; it's done by our caller because
* the TraceVarInfo is really part of a CompoundVarTrace. [Bug 1348775]
*/
result = NULL;
if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)) {
if (tvarPtr->length != (size_t) 0) {
/*
* Generate a command to execute by appending list elements
* for the two variable names and the operation.
*/
Tcl_DStringInit(&cmd);
|
| ︙ | ︙ | |||
4666 4667 4668 4669 4670 4671 4672 | * * Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to * other areas that this will be destroyed by us, otherwise a * double-free might occur depending on what the eval does. */ Tcl_SaveResult(interp, &state); | | > > | < < | 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 |
*
* Add the TCL_TRACE_DESTROYED flag to tvarPtr to indicate to
* other areas that this will be destroyed by us, otherwise a
* double-free might occur depending on what the eval does.
*/
Tcl_SaveResult(interp, &state);
if ((flags & TCL_TRACE_DESTROYED)
&& !(tvarPtr->flags & TCL_TRACE_DESTROYED)) {
destroy = 1;
tvarPtr->flags |= TCL_TRACE_DESTROYED;
}
code = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
Tcl_DStringLength(&cmd), 0);
if (code != TCL_OK) { /* copy error msg to result */
register Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errMsgObj);
result = (char *) errMsgObj;
}
Tcl_RestoreResult(interp, &state);
Tcl_DStringFree(&cmd);
}
}
if (destroy) {
if (result != NULL) {
register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
Tcl_DecrRefCount(errMsgObj);
result = NULL;
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_WhileObjCmd --
|
| ︙ | ︙ | |||
4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 |
Tcl_WhileObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "test command");
return TCL_ERROR;
}
while (1) {
result = Tcl_ExprBooleanObj(interp, objv[1], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
result = Tcl_EvalObjEx(interp, objv[2], 0);
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"while\" body line %d)",
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
}
}
if (result == TCL_BREAK) {
result = TCL_OK;
}
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
return result;
}
| > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 |
Tcl_WhileObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int result, value;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "test command");
return TCL_ERROR;
}
while (1) {
result = Tcl_ExprBooleanObj(interp, objv[1], &value);
if (result != TCL_OK) {
return result;
}
if (!value) {
break;
}
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[2], 0);
#else
/* TIP #280. */
result = TclEvalObjEx(interp, objv[2], 0, iPtr->cmdFramePtr,2);
#endif
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"while\" body line %d)",
interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
}
}
if (result == TCL_BREAK) {
result = TCL_OK;
}
if (result == TCL_OK) {
Tcl_ResetResult(interp);
}
return result;
}
#ifdef TCL_TIP280
static void
ListLines(listStr, line, n, lines)
CONST char* listStr; /* Pointer to string with list structure.
* Assumed to be valid. Assumed to contain
* n elements.
*/
int line; /* line the list as a whole starts on */
int n; /* #elements in lines */
int* lines; /* Array of line numbers, to fill */
{
int i;
int length = strlen( listStr);
CONST char *element = NULL;
CONST char* next = NULL;
for (i = 0; i < n; i++) {
TclFindElement(NULL, listStr, length, &element, &next, NULL, NULL);
TclAdvanceLines (&line, listStr, element); /* Leading whitespace */
lines [i] = line;
length -= (next - listStr);
TclAdvanceLines (&line, element, next); /* Element */
listStr = next;
if (*element == 0) {
/* ASSERT i == n */
break;
}
}
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCompCmds.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
/*
* tclCompCmds.c --
*
* This file contains compilation procedures that compile various
* Tcl commands into a sequence of instructions ("bytecodes").
*
* Copyright (c) 1997-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2002 ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
| | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
/*
* tclCompCmds.c --
*
* This file contains compilation procedures that compile various
* Tcl commands into a sequence of instructions ("bytecodes").
*
* Copyright (c) 1997-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
* Copyright (c) 2002 ActiveState Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclCompCmds.c,v 1.39.2.6 2007/03/01 16:06:19 dkf Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* Prototypes for procedures defined later in this file:
*/
static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
static void FreeForeachInfo _ANSI_ARGS_((ClientData clientData));
#ifndef TCL_TIP280
static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr));
#else
static int TclPushVarName _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags,
int *localIndexPtr, int *simpleVarNamePtr, int *isScalarPtr,
int line));
#endif
/*
* Flags bits used by TclPushVarName.
*/
#define TCL_CREATE_VAR 1 /* Create a compiled local if none is found */
#define TCL_NO_LARGE_INDEX 2 /* Do not return localIndex value > 255 */
|
| ︙ | ︙ | |||
73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int simpleVarName, isScalar, localIndex, numWords;
int code = TCL_OK;
numWords = parsePtr->numWords;
if (numWords == 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"append varName ?value value ...?\"",
-1);
| > > > > > > > > > > | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int simpleVarName, isScalar, localIndex, numWords;
int code = TCL_OK;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
numWords = parsePtr->numWords;
if (numWords == 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"append varName ?value value ...?\"",
-1);
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
&localIndex, &simpleVarName, &isScalar);
if (code != TCL_OK) {
goto done;
}
/*
* We are doing an assignment, otherwise TclCompileSetCmd was called,
* so push the new value. This will need to be extended to push a
* value for each argument.
*/
if (numWords > 2) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
}
| > > > > > > > > | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
#ifndef TCL_TIP280
&localIndex, &simpleVarName, &isScalar);
#else
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc [eclIndex].line [1]);
#endif
if (code != TCL_OK) {
goto done;
}
/*
* We are doing an assignment, otherwise TclCompileSetCmd was called,
* so push the new value. This will need to be extended to push a
* value for each argument.
*/
if (numWords > 2) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [2];
#endif
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
}
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
{
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *nameTokenPtr;
CONST char *name;
int localIndex, nameChars, range, startOffset, jumpDist;
int code;
int savedStackDepth = envPtr->currStackDepth;
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"catch command ?varName?\"", -1);
return TCL_ERROR;
}
| > > > > > > > > > > | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 |
{
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *nameTokenPtr;
CONST char *name;
int localIndex, nameChars, range, startOffset, jumpDist;
int code;
int savedStackDepth = envPtr->currStackDepth;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"catch command ?varName?\"", -1);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
* text without catching, a catch instruction that resets the
* stack to what it was before substituting the body, and then
* an instruction to eval the body. Care has to be taken to
* register the correct startOffset for the catch range so that
* errors in the substitution are not catched [Bug 219184]
*/
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
startOffset = (envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
} else {
code = TclCompileTokens(interp, cmdTokenPtr+1,
cmdTokenPtr->numComponents, envPtr);
startOffset = (envPtr->codeNext - envPtr->codeStart);
| > > > | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
* text without catching, a catch instruction that resets the
* stack to what it was before substituting the body, and then
* an instruction to eval the body. Care has to be taken to
* register the correct startOffset for the catch range so that
* errors in the substitution are not catched [Bug 219184]
*/
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [1];
#endif
if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
startOffset = (envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, cmdTokenPtr+1, 1, envPtr);
} else {
code = TclCompileTokens(interp, cmdTokenPtr+1,
cmdTokenPtr->numComponents, envPtr);
startOffset = (envPtr->codeNext - envPtr->codeStart);
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 465 466 467 468 469 470 471 |
if (parsePtr->numWords == 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"expr arg ?arg ...?\"", -1);
return TCL_ERROR;
}
firstWordPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
envPtr);
}
/*
| > > > > > | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 |
if (parsePtr->numWords == 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"expr arg ?arg ...?\"", -1);
return TCL_ERROR;
}
#ifdef TCL_TIP280
/* TIP #280 : Use the per-word line information of the current command.
*/
envPtr->line = envPtr->extCmdMapPtr->loc [envPtr->extCmdMapPtr->nuloc - 1].line [1];
#endif
firstWordPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
return TclCompileExprWords(interp, firstWordPtr, (parsePtr->numWords-1),
envPtr);
}
/*
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
{
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange, code;
char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
if (parsePtr->numWords != 5) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"for start test next command\"", -1);
return TCL_ERROR;
}
| > > > > > > > > > > | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 |
{
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange, code;
char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
if (parsePtr->numWords != 5) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"for start test next command\"", -1);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 551 552 553 554 555 556 557 |
bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
* Inline compile the initial command.
*/
code = TclCompileCmdWord(interp, startTokenPtr+1,
startTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"for\" initial command)", -1);
}
| > > > | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
bodyRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
nextRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
/*
* Inline compile the initial command.
*/
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [1];
#endif
code = TclCompileCmdWord(interp, startTokenPtr+1,
startTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"for\" initial command)", -1);
}
|
| ︙ | ︙ | |||
575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
/*
* Compile the loop body.
*/
bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"for\" body line %d)",
interp->errorLine);
| > > > | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 |
/*
* Compile the loop body.
*/
bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [4];
#endif
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"for\" body line %d)",
interp->errorLine);
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
/*
* Compile the "next" subcommand.
*/
nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);
envPtr->currStackDepth = savedStackDepth;
code = TclCompileCmdWord(interp, nextTokenPtr+1,
nextTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
| > > > | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 |
/*
* Compile the "next" subcommand.
*/
nextCodeOffset = (envPtr->codeNext - envPtr->codeStart);
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [3];
#endif
envPtr->currStackDepth = savedStackDepth;
code = TclCompileCmdWord(interp, nextTokenPtr+1,
nextTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
|
| ︙ | ︙ | |||
627 628 629 630 631 632 633 |
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
bodyCodeOffset += 3;
nextCodeOffset += 3;
testCodeOffset += 3;
}
| | > > | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 |
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
bodyCodeOffset += 3;
nextCodeOffset += 3;
testCodeOffset += 3;
}
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [2];
#endif
envPtr->currStackDepth = savedStackDepth;
code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"for\" test expression)", -1);
}
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
/*
* We parse the variable list argument words and create two arrays:
* varcList[i] is number of variables in i-th var list
* varvList[i] points to array of var names in i-th var list
*/
#define STATIC_VAR_LIST_SIZE 5
| > > > > > > > > > > > | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 |
unsigned char *jumpPc;
JumpFixup jumpFalseFixup;
int jumpDist, jumpBackDist, jumpBackOffset, infoIndex, range;
int numWords, numLists, numVars, loopIndex, tempVar, i, j, code;
char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
int bodyIndex;
#endif
/*
* We parse the variable list argument words and create two arrays:
* varcList[i] is number of variables in i-th var list
* varvList[i] points to array of var names in i-th var list
*/
#define STATIC_VAR_LIST_SIZE 5
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 766 767 768 769 770 771 772 |
i < numWords-1;
i++, tokenPtr += (tokenPtr->numComponents + 1)) {
}
bodyTokenPtr = tokenPtr;
if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_OUT_LINE_COMPILE;
}
/*
* Allocate storage for the varcList and varvList arrays if necessary.
*/
numLists = (numWords - 2)/2;
if (numLists > STATIC_VAR_LIST_SIZE) {
| > > > | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 |
i < numWords-1;
i++, tokenPtr += (tokenPtr->numComponents + 1)) {
}
bodyTokenPtr = tokenPtr;
if (bodyTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_OUT_LINE_COMPILE;
}
#ifdef TCL_TIP280
bodyIndex = i-1;
#endif
/*
* Allocate storage for the varcList and varvList arrays if necessary.
*/
numLists = (numWords - 2)/2;
if (numLists > STATIC_VAR_LIST_SIZE) {
|
| ︙ | ︙ | |||
812 813 814 815 816 817 818 819 820 821 822 823 824 825 |
code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
&varcList[loopIndex], &varvList[loopIndex]);
Tcl_DStringFree(&varList);
if (code != TCL_OK) {
goto done;
}
numVars = varcList[loopIndex];
for (j = 0; j < numVars; j++) {
CONST char *varName = varvList[loopIndex][j];
if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
code = TCL_OUT_LINE_COMPILE;
goto done;
}
}
| > > > > > > > > > > > > | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 |
code = Tcl_SplitList(interp, Tcl_DStringValue(&varList),
&varcList[loopIndex], &varvList[loopIndex]);
Tcl_DStringFree(&varList);
if (code != TCL_OK) {
goto done;
}
numVars = varcList[loopIndex];
/*
* If the variable list is empty, we can enter an infinite
* loop when the interpreted version would not. Take care to
* ensure this does not happen. [Bug 1671138]
*/
if (numVars == 0) {
code = TCL_OUT_LINE_COMPILE;
goto done;
}
for (j = 0; j < numVars; j++) {
CONST char *varName = varvList[loopIndex][j];
if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
code = TCL_OUT_LINE_COMPILE;
goto done;
}
}
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 889 890 891 892 893 894 895 |
range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
loopIndex = 0;
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr += (tokenPtr->numComponents + 1)) {
if ((i%2 == 0) && (i > 0)) {
code = TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
tempVar = (firstValueTemp + loopIndex);
| > > > | 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 |
range = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr);
loopIndex = 0;
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr += (tokenPtr->numComponents + 1)) {
if ((i%2 == 0) && (i > 0)) {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [i];
#endif
code = TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
tempVar = (firstValueTemp + loopIndex);
|
| ︙ | ︙ | |||
919 920 921 922 923 924 925 926 927 928 929 930 931 932 |
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
/*
* Inline compile the loop body.
*/
envPtr->exceptArrayPtr[range].codeOffset =
(envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
| > > > | 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 |
TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
/*
* Inline compile the loop body.
*/
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [bodyIndex];
#endif
envPtr->exceptArrayPtr[range].codeOffset =
(envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
|
| ︙ | ︙ | |||
1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 |
/* Saved stack depth at the start of the first
* test; the envPtr current depth is restored
* to this value at the start of each test. */
int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */
int boolVal; /* value of static condition */
int compileScripts = 1;
/*
* Only compile the "if" command if all arguments are simple
* words, in order to insure correct substitution [Bug 219166]
*/
tokenPtr = parsePtr->tokenPtr;
wordIdx = 0;
| > > > > > > > > > > | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 |
/* Saved stack depth at the start of the first
* test; the envPtr current depth is restored
* to this value at the start of each test. */
int realCond = 1; /* set to 0 for static conditions: "if 0 {..}" */
int boolVal; /* value of static condition */
int compileScripts = 1;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
/*
* Only compile the "if" command if all arguments are simple
* words, in order to insure correct substitution [Bug 219166]
*/
tokenPtr = parsePtr->tokenPtr;
wordIdx = 0;
|
| ︙ | ︙ | |||
1192 1193 1194 1195 1196 1197 1198 |
tokenPtr += (tokenPtr->numComponents + 1);
wordIdx++;
} else {
break;
}
if (wordIdx >= numWords) {
sprintf(buffer,
| | | | 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 |
tokenPtr += (tokenPtr->numComponents + 1);
wordIdx++;
} else {
break;
}
if (wordIdx >= numWords) {
sprintf(buffer,
"wrong # args: no expression after \"%.*s\" argument",
(numBytes > 50 ? 50 : numBytes), word);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
code = TCL_ERROR;
goto done;
}
/*
|
| ︙ | ︙ | |||
1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 |
*/
realCond = 0;
if (!boolVal) {
compileScripts = 0;
}
} else {
Tcl_ResetResult(interp);
code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"if\" test expression)", -1);
}
goto done;
| > > > | 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
*/
realCond = 0;
if (!boolVal) {
compileScripts = 0;
}
} else {
Tcl_ResetResult(interp);
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
#endif
code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"if\" test expression)", -1);
}
goto done;
|
| ︙ | ︙ | |||
1255 1256 1257 1258 1259 1260 1261 |
/*
* Skip over the optional "then" before the then clause.
*/
tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
wordIdx++;
if (wordIdx >= numWords) {
| > | > > | 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 |
/*
* Skip over the optional "then" before the then clause.
*/
tokenPtr = testTokenPtr + (testTokenPtr->numComponents + 1);
wordIdx++;
if (wordIdx >= numWords) {
sprintf(buffer,
"wrong # args: no script following \"%.*s\" argument",
(testTokenPtr->size > 50 ? 50 : testTokenPtr->size),
testTokenPtr->start);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buffer, -1);
code = TCL_ERROR;
goto done;
}
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
word = tokenPtr[1].start;
|
| ︙ | ︙ | |||
1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 |
}
/*
* Compile the "then" command body.
*/
if (compileScripts) {
envPtr->currStackDepth = savedStackDepth;
code = TclCompileCmdWord(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"if\" then script line %d)",
interp->errorLine);
| > > > | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 |
}
/*
* Compile the "then" command body.
*/
if (compileScripts) {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
#endif
envPtr->currStackDepth = savedStackDepth;
code = TclCompileCmdWord(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"if\" then script line %d)",
interp->errorLine);
|
| ︙ | ︙ | |||
1384 1385 1386 1387 1388 1389 1390 |
}
}
if (compileScripts) {
/*
* Compile the else command body.
*/
| | > > | 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
}
}
if (compileScripts) {
/*
* Compile the else command body.
*/
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [wordIdx];
#endif
code = TclCompileCmdWord(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"if\" else script line %d)",
interp->errorLine);
Tcl_AddObjErrorInfo(interp, buffer, -1);
|
| ︙ | ︙ | |||
1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 |
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *incrTokenPtr;
int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
int code = TCL_OK;
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"incr varName ?increment?\"", -1);
return TCL_ERROR;
}
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarName(interp, varTokenPtr, envPtr,
(TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
&localIndex, &simpleVarName, &isScalar);
if (code != TCL_OK) {
goto done;
}
/*
* If an increment is given, push it, but see first if it's a small
* integer.
*/
haveImmValue = 0;
| > > > > > > > > > > > > > > > | < < | | < | | | | | | > < > > > < | 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 |
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *incrTokenPtr;
int simpleVarName, isScalar, localIndex, haveImmValue, immValue;
int code = TCL_OK;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"incr varName ?increment?\"", -1);
return TCL_ERROR;
}
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarName(interp, varTokenPtr, envPtr,
(TCL_NO_LARGE_INDEX | TCL_CREATE_VAR),
#ifndef TCL_TIP280
&localIndex, &simpleVarName, &isScalar);
#else
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc [eclIndex].line [1]);
#endif
if (code != TCL_OK) {
goto done;
}
/*
* If an increment is given, push it, but see first if it's a small
* integer.
*/
haveImmValue = 0;
immValue = 1;
if (parsePtr->numWords == 3) {
incrTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
CONST char *word = incrTokenPtr[1].start;
int numBytes = incrTokenPtr[1].size;
/*
* Note there is a danger that modifying the string could have
* undesirable side effects. In this case, TclLooksLikeInt has
* no dependencies on shared strings so we should be safe.
*/
if (TclLooksLikeInt(word, numBytes)) {
int code;
Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(intObj);
code = Tcl_GetIntFromObj(NULL, intObj, &immValue);
Tcl_DecrRefCount(intObj);
if ((code == TCL_OK)
&& (-127 <= immValue) && (immValue <= 127)) {
haveImmValue = 1;
}
}
if (!haveImmValue) {
TclEmitPush(
TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
}
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [2];
#endif
code = TclCompileTokens(interp, incrTokenPtr+1,
incrTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
} else { /* no incr amount given so use 1 */
haveImmValue = 1;
}
/*
* Emit the instruction to increment the variable.
*/
if (simpleVarName) {
|
| ︙ | ︙ | |||
1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 |
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int simpleVarName, isScalar, localIndex, numWords;
int code = TCL_OK;
/*
* If we're not in a procedure, don't compile.
*/
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
| > > > > > > > > > > | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 |
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int simpleVarName, isScalar, localIndex, numWords;
int code = TCL_OK;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
/*
* If we're not in a procedure, don't compile.
*/
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
|
| ︙ | ︙ | |||
1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 |
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
&localIndex, &simpleVarName, &isScalar);
if (code != TCL_OK) {
goto done;
}
/*
* If we are doing an assignment, push the new value.
* In the no values case, create an empty object.
*/
if (numWords > 2) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
}
| > > > > > > > > | 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 |
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
#ifndef TCL_TIP280
&localIndex, &simpleVarName, &isScalar);
#else
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc [eclIndex].line [1]);
#endif
if (code != TCL_OK) {
goto done;
}
/*
* If we are doing an assignment, push the new value.
* In the no values case, create an empty object.
*/
if (numWords > 2) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [2];
#endif
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
}
|
| ︙ | ︙ | |||
1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 |
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int code, i;
int numWords;
numWords = parsePtr->numWords;
/*
* Quit if too few args
*/
| > > > > > > > > > > | 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 |
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int code, i;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
int numWords;
numWords = parsePtr->numWords;
/*
* Quit if too few args
*/
|
| ︙ | ︙ | |||
1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 |
for ( i = 1 ; i < numWords ; i++ ) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(
TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
| > > > | 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 |
for ( i = 1 ; i < numWords ; i++ ) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(
TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [i];
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
|
| ︙ | ︙ | |||
1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 |
int
TclCompileListCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
/*
* If we're not in a procedure, don't compile.
*/
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
| > > > > > > > > > > | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 |
int
TclCompileListCmd(interp, parsePtr, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
/*
* If we're not in a procedure, don't compile.
*/
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
|
| ︙ | ︙ | |||
1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 |
valueTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
for (i = 1; i < numWords; i++) {
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
| > > > | 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 |
valueTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
for (i = 1; i < numWords; i++) {
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
valueTokenPtr[1].start, valueTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [i];
#endif
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
valueTokenPtr = valueTokenPtr + (valueTokenPtr->numComponents + 1);
|
| ︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 |
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int code;
if (parsePtr->numWords != 2) {
Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
TCL_STATIC);
return TCL_ERROR;
}
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* We could simply count the number of elements here and push
* that value, but that is too rare a case to waste the code space.
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
TclEmitOpcode(INST_LIST_LENGTH, envPtr);
| > > > > > > > > > > > > > | 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 |
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int code;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
if (parsePtr->numWords != 2) {
Tcl_SetResult(interp, "wrong # args: should be \"llength list\"",
TCL_STATIC);
return TCL_ERROR;
}
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* We could simply count the number of elements here and push
* that value, but that is too rare a case to waste the code space.
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [1];
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
TclEmitOpcode(INST_LIST_LENGTH, envPtr);
|
| ︙ | ︙ | |||
2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 |
int result; /* Status return from library calls */
int localIndex; /* Index of var in local var table */
int simpleVarName; /* Flag == 1 if var name is simple */
int isScalar; /* Flag == 1 if scalar, 0 if array */
int i;
/* Check argument count */
if ( parsePtr->numWords < 3 ) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
* frame slot (entry in the array of local vars) if we are compiling a
* procedure body and if the name is simple text that does not include
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
result = TclPushVarName( interp, varTokenPtr, envPtr,
TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar );
if (result != TCL_OK) {
return result;
}
/* Push the "index" args and the new element value. */
for ( i = 2; i < parsePtr->numWords; ++i ) {
/* Advance to next arg */
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
/* Push an arg */
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
result = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if ( result != TCL_OK ) {
return result;
}
}
}
| > > > > > > > > > > > > > > > > > > | 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 |
int result; /* Status return from library calls */
int localIndex; /* Index of var in local var table */
int simpleVarName; /* Flag == 1 if var name is simple */
int isScalar; /* Flag == 1 if scalar, 0 if array */
int i;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
/* Check argument count */
if ( parsePtr->numWords < 3 ) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
/*
* Decide if we can use a frame slot for the var/array name or if we
* need to emit code to compute and push the name at runtime. We use a
* frame slot (entry in the array of local vars) if we are compiling a
* procedure body and if the name is simple text that does not include
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
result = TclPushVarName( interp, varTokenPtr, envPtr,
#ifndef TCL_TIP280
TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar );
#else
TCL_CREATE_VAR, &localIndex, &simpleVarName, &isScalar,
mapPtr->loc [eclIndex].line [1]);
#endif
if (result != TCL_OK) {
return result;
}
/* Push the "index" args and the new element value. */
for ( i = 2; i < parsePtr->numWords; ++i ) {
/* Advance to next arg */
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
/* Push an arg */
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral( envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [i];
#endif
result = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if ( result != TCL_OK ) {
return result;
}
}
}
|
| ︙ | ︙ | |||
2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 |
* the command */
CompileEnv* envPtr; /* Holds the resulting instructions */
{
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing
* the parse of the RE or string */
int i, len, code, nocase, anchorLeft, anchorRight, start;
char *str;
/*
* We are only interested in compiling simple regexp cases.
* Currently supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
| > > > > > > > > > > | 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 |
* the command */
CompileEnv* envPtr; /* Holds the resulting instructions */
{
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing
* the parse of the RE or string */
int i, len, code, nocase, anchorLeft, anchorRight, start;
char *str;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
/*
* We are only interested in compiling simple regexp cases.
* Currently supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
|
| ︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 |
* Push the string arg
*/
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
| > > > | 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 |
* Push the string arg
*/
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [parsePtr->numWords-1];
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
|
| ︙ | ︙ | |||
2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 |
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int code;
int index = envPtr->exceptArrayNext - 1;
/*
* If we're not in a procedure, don't compile.
*/
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
| > > > > > > > > > > | 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 |
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr;
int code;
int index = envPtr->exceptArrayNext - 1;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
/*
* If we're not in a procedure, don't compile.
*/
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
|
| ︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 |
/*
* Parse token is more complex, so compile it; this handles the
* variable reference and nested command cases. If the
* parse token can be byte-compiled, then this instance of
* "return" will be byte-compiled; otherwise it will be
* out line compiled.
*/
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
break;
| > > > | 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 |
/*
* Parse token is more complex, so compile it; this handles the
* variable reference and nested command cases. If the
* parse token can be byte-compiled, then this instance of
* "return" will be byte-compiled; otherwise it will be
* out line compiled.
*/
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [1];
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
break;
|
| ︙ | ︙ | |||
2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 |
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isAssignment, isScalar, simpleVarName, localIndex, numWords;
int code = TCL_OK;
numWords = parsePtr->numWords;
if ((numWords != 2) && (numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"set varName ?newValue?\"", -1);
return TCL_ERROR;
| > > > > > > > > > > | 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 |
Tcl_Parse *parsePtr; /* Points to a parse structure for the
* command created by Tcl_ParseCommand. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isAssignment, isScalar, simpleVarName, localIndex, numWords;
int code = TCL_OK;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
numWords = parsePtr->numWords;
if ((numWords != 2) && (numWords != 3)) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"set varName ?newValue?\"", -1);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 |
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
&localIndex, &simpleVarName, &isScalar);
if (code != TCL_OK) {
goto done;
}
/*
* If we are doing an assignment, push the new value.
*/
if (isAssignment) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
valueTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
}
| > > > > > > > > | 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 |
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
code = TclPushVarName(interp, varTokenPtr, envPtr, TCL_CREATE_VAR,
#ifndef TCL_TIP280
&localIndex, &simpleVarName, &isScalar);
#else
&localIndex, &simpleVarName, &isScalar,
mapPtr->loc [eclIndex].line [1]);
#endif
if (code != TCL_OK) {
goto done;
}
/*
* If we are doing an assignment, push the new value.
*/
if (isAssignment) {
valueTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
if (valueTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr, valueTokenPtr[1].start,
valueTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [2];
#endif
code = TclCompileTokens(interp, valueTokenPtr+1,
valueTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
}
|
| ︙ | ︙ | |||
2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 |
STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
STR_WORDEND, STR_WORDSTART
};
if (parsePtr->numWords < 2) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
opTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
| > > > > > > > > > > | 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 |
STR_BYTELENGTH, STR_COMPARE, STR_EQUAL, STR_FIRST,
STR_INDEX, STR_IS, STR_LAST, STR_LENGTH,
STR_MAP, STR_MATCH, STR_RANGE, STR_REPEAT,
STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE,
STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT,
STR_WORDEND, STR_WORDSTART
};
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
if (parsePtr->numWords < 2) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
opTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
|
| ︙ | ︙ | |||
2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 |
*/
for (i = 0; i < 2; i++) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
| > > > | 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 |
*/
for (i = 0; i < 2; i++) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [i];
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
|
| ︙ | ︙ | |||
2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 |
*/
for (i = 0; i < 2; i++) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
} else {
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
| > > > | 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 |
*/
for (i = 0; i < 2; i++) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
TclEmitPush(TclRegisterNewLiteral(envPtr,
varTokenPtr[1].start, varTokenPtr[1].size), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [i];
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
|
| ︙ | ︙ | |||
2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 |
char buf[TCL_INTEGER_SPACE];
int len = Tcl_NumUtfChars(varTokenPtr[1].start,
varTokenPtr[1].size);
len = sprintf(buf, "%d", len);
TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
return TCL_OK;
} else {
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
TclEmitOpcode(INST_STR_LEN, envPtr);
| > > > | 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 |
char buf[TCL_INTEGER_SPACE];
int len = Tcl_NumUtfChars(varTokenPtr[1].start,
varTokenPtr[1].size);
len = sprintf(buf, "%d", len);
TclEmitPush(TclRegisterNewLiteral(envPtr, buf, len), envPtr);
return TCL_OK;
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [2];
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
TclEmitOpcode(INST_STR_LEN, envPtr);
|
| ︙ | ︙ | |||
2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 |
exactMatch = (strpbrk(Tcl_GetString(copy),
"*[]?\\") == NULL);
Tcl_DecrRefCount(copy);
}
TclEmitPush(
TclRegisterNewLiteral(envPtr, str, length), envPtr);
} else {
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
| > > > | 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 |
exactMatch = (strpbrk(Tcl_GetString(copy),
"*[]?\\") == NULL);
Tcl_DecrRefCount(copy);
}
TclEmitPush(
TclRegisterNewLiteral(envPtr, str, length), envPtr);
} else {
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [i];
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
return code;
}
}
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
|
| ︙ | ︙ | |||
2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 |
int range, code;
char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as
* an infinite loop. */
Tcl_Obj *boolObj;
int boolVal;
if (parsePtr->numWords != 3) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"while test command\"", -1);
return TCL_ERROR;
}
| > > > > > > > > > > | 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 |
int range, code;
char buffer[32 + TCL_INTEGER_SPACE];
int savedStackDepth = envPtr->currStackDepth;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as
* an infinite loop. */
Tcl_Obj *boolObj;
int boolVal;
#ifdef TCL_TIP280
/* TIP #280 : Remember the per-word line information of the current
* command. An index is used instead of a pointer as recursive compilation
* may reallocate, i.e. move, the array. This is also the reason to save
* the nuloc now, it may change during the course of the function.
*/
ExtCmdLoc* mapPtr = envPtr->extCmdMapPtr;
int eclIndex = mapPtr->nuloc - 1;
#endif
if (parsePtr->numWords != 3) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"wrong # args: should be \"while test command\"", -1);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 |
}
/*
* Compile the loop body.
*/
bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"while\" body line %d)",
| > > > | 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 |
}
/*
* Compile the loop body.
*/
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [2];
#endif
bodyCodeOffset = (envPtr->codeNext - envPtr->codeStart);
code = TclCompileCmdWord(interp, bodyTokenPtr+1,
bodyTokenPtr->numComponents, envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
if (code != TCL_OK) {
if (code == TCL_ERROR) {
sprintf(buffer, "\n (\"while\" body line %d)",
|
| ︙ | ︙ | |||
3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 |
testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
bodyCodeOffset += 3;
testCodeOffset += 3;
}
envPtr->currStackDepth = savedStackDepth;
code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"while\" test expression)", -1);
}
goto error;
| > > > | 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 |
testCodeOffset = (envPtr->codeNext - envPtr->codeStart);
jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) {
bodyCodeOffset += 3;
testCodeOffset += 3;
}
envPtr->currStackDepth = savedStackDepth;
#ifdef TCL_TIP280
envPtr->line = mapPtr->loc [eclIndex].line [1];
#endif
code = TclCompileExprWords(interp, testTokenPtr, 1, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
"\n (\"while\" test expression)", -1);
}
goto error;
|
| ︙ | ︙ | |||
3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 |
* at runtime.
*
*----------------------------------------------------------------------
*/
static int
TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
simpleVarNamePtr, isScalarPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Token *varTokenPtr; /* Points to a variable token. */
CompileEnv *envPtr; /* Holds resulting instructions. */
int flags; /* takes TCL_CREATE_VAR or
* TCL_NO_LARGE_INDEX */
int *localIndexPtr; /* must not be NULL */
int *simpleVarNamePtr; /* must not be NULL */
int *isScalarPtr; /* must not be NULL */
{
register CONST char *p;
CONST char *name, *elName;
register int i, n;
int nameChars, elNameChars, simpleVarName, localIndex;
int code = TCL_OK;
| > > > > > > > | 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 |
* at runtime.
*
*----------------------------------------------------------------------
*/
static int
TclPushVarName(interp, varTokenPtr, envPtr, flags, localIndexPtr,
#ifndef TCL_TIP280
simpleVarNamePtr, isScalarPtr)
#else
simpleVarNamePtr, isScalarPtr, line)
#endif
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Token *varTokenPtr; /* Points to a variable token. */
CompileEnv *envPtr; /* Holds resulting instructions. */
int flags; /* takes TCL_CREATE_VAR or
* TCL_NO_LARGE_INDEX */
int *localIndexPtr; /* must not be NULL */
int *simpleVarNamePtr; /* must not be NULL */
int *isScalarPtr; /* must not be NULL */
#ifdef TCL_TIP280
int line; /* line the token starts on */
#endif
{
register CONST char *p;
CONST char *name, *elName;
register int i, n;
int nameChars, elNameChars, simpleVarName, localIndex;
int code = TCL_OK;
|
| ︙ | ︙ | |||
3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 |
/*
* Compile the element script, if any.
*/
if (elName != NULL) {
if (elNameChars) {
code = TclCompileTokens(interp, elemTokenPtr,
elemTokenCount, envPtr);
if (code != TCL_OK) {
goto done;
}
} else {
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
}
}
} else {
/*
* The var name isn't simple: compile and push it.
*/
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
done:
if (removedParen) {
++varTokenPtr[removedParen].size;
}
if (allocedTokens) {
ckfree((char *) elemTokenPtr);
}
*localIndexPtr = localIndex;
*simpleVarNamePtr = simpleVarName;
*isScalarPtr = (elName == NULL);
return code;
}
| > > > > > > > > > > > > > > > | 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 |
/*
* Compile the element script, if any.
*/
if (elName != NULL) {
if (elNameChars) {
#ifdef TCL_TIP280
envPtr->line = line;
#endif
code = TclCompileTokens(interp, elemTokenPtr,
elemTokenCount, envPtr);
if (code != TCL_OK) {
goto done;
}
} else {
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
}
}
} else {
/*
* The var name isn't simple: compile and push it.
*/
#ifdef TCL_TIP280
envPtr->line = line;
#endif
code = TclCompileTokens(interp, varTokenPtr+1,
varTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto done;
}
}
done:
if (removedParen) {
++varTokenPtr[removedParen].size;
}
if (allocedTokens) {
ckfree((char *) elemTokenPtr);
}
*localIndexPtr = localIndex;
*simpleVarNamePtr = simpleVarName;
*isScalarPtr = (elName == NULL);
return code;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCompExpr.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclCompExpr.c -- * * This file contains the code to compile Tcl expressions. * * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclCompExpr.c -- * * This file contains the code to compile Tcl expressions. * * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCompExpr.c,v 1.13.2.3 2006/11/28 22:20:00 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * The stuff below is a bit of a hack so that this file can be used in |
| ︙ | ︙ | |||
253 254 255 256 257 258 259 260 261 262 263 264 265 266 |
* Parse the expression then compile it.
*/
code = Tcl_ParseExpr(interp, script, numBytes, &parse);
if (code != TCL_OK) {
goto done;
}
code = CompileSubExpr(parse.tokenPtr, &info, envPtr);
if (code != TCL_OK) {
Tcl_FreeParse(&parse);
goto done;
}
| > > > > > | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
* Parse the expression then compile it.
*/
code = Tcl_ParseExpr(interp, script, numBytes, &parse);
if (code != TCL_OK) {
goto done;
}
#ifdef TCL_TIP280
/* TIP #280 : Track Lines within the expression */
TclAdvanceLines (&envPtr->line, script, parse.tokenPtr->start);
#endif
code = CompileSubExpr(parse.tokenPtr, &info, envPtr);
if (code != TCL_OK) {
Tcl_FreeParse(&parse);
goto done;
}
|
| ︙ | ︙ | |||
282 283 284 285 286 287 288 | /* *---------------------------------------------------------------------- * * TclFinalizeCompilation -- * * Clean up the compilation environment so it can later be | | < < | 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 | /* *---------------------------------------------------------------------- * * TclFinalizeCompilation -- * * Clean up the compilation environment so it can later be * properly reinitialized. This procedure is called by Tcl_Finalize(). * * Results: * None. * * Side effects: * Cleans up the compilation environment. At the moment, just the * table of expression operators is freed. |
| ︙ | ︙ | |||
336 337 338 339 340 341 342 |
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* to compile. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Interp *interp = infoPtr->interp;
| | > | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* to compile. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Interp *interp = infoPtr->interp;
Tcl_Token *tokenPtr, *endPtr = NULL; /* silence gcc 4 warning */
Tcl_Token *afterSubexprPtr;
OperatorDesc *opDescPtr;
Tcl_HashEntry *hPtr;
CONST char *operator;
Tcl_DString opBuf;
int objIndex, opIndex, length, code;
char buffer[TCL_UTF_MAX];
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
/*
* tclCompile.c --
*
* This file contains procedures that compile Tcl commands or parts
* of commands (like quoted strings or nested sub-commands) into a
* sequence of instructions ("bytecodes").
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
/*
* tclCompile.c --
*
* This file contains procedures that compile Tcl commands or parts
* of commands (like quoted strings or nested sub-commands) into a
* sequence of instructions ("bytecodes").
*
* Copyright (c) 1996-1998 Sun Microsystems, Inc.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclCompile.c,v 1.43.2.7 2006/11/28 22:20:00 andreas_kupries Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* Table of all AuxData types.
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
int length));
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats _ANSI_ARGS_((
ByteCode *codePtr));
#endif /* TCL_COMPILE_STATS */
static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
/*
* The structure below defines the bytecode Tcl object type by
* means of procedures that can be invoked by generic object code.
*/
Tcl_ObjType tclByteCodeType = {
| > > > > > > > > > > | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 |
int length));
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats _ANSI_ARGS_((
ByteCode *codePtr));
#endif /* TCL_COMPILE_STATS */
static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#ifdef TCL_TIP280
/* TIP #280 : Helper for building the per-word line information of all
* compiled commands */
static void EnterCmdWordData _ANSI_ARGS_((
ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr,
CONST char* cmd, int len, int numWords, int line,
int** lines));
#endif
/*
* The structure below defines the bytecode Tcl object type by
* means of procedures that can be invoked by generic object code.
*/
Tcl_ObjType tclByteCodeType = {
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
if (iPtr->evalFlags & TCL_BRACKET_TERM) {
nested = 1;
} else {
nested = 0;
}
string = Tcl_GetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string, length);
result = TclCompileScript(interp, string, length, nested, &compEnv);
if (result == TCL_OK) {
/*
* Successful compilation. Add a "done" instruction at the end.
*/
| > > > > > > > > > > > > | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 |
if (iPtr->evalFlags & TCL_BRACKET_TERM) {
nested = 1;
} else {
nested = 0;
}
string = Tcl_GetStringFromObj(objPtr, &length);
#ifndef TCL_TIP280
TclInitCompileEnv(interp, &compEnv, string, length);
#else
/*
* TIP #280. Pick up the CmdFrame in which the BC compiler was invoked
* and use to initialize the tracking in the compiler. This information
* was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc
* (tclProc.c).
*/
TclInitCompileEnv(interp, &compEnv, string, length,
iPtr->invokeCmdFramePtr, iPtr->invokeWord);
#endif
result = TclCompileScript(interp, string, length, nested, &compEnv);
if (result == TCL_OK) {
/*
* Successful compilation. Add a "done" instruction at the end.
*/
|
| ︙ | ︙ | |||
562 563 564 565 566 567 568 569 570 571 572 573 574 575 |
*/
void
TclCleanupByteCode(codePtr)
register ByteCode *codePtr; /* Points to the ByteCode to free. */
{
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
int numLitObjects = codePtr->numLitObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
register Tcl_Obj **objArrayPtr;
register AuxData *auxDataPtr;
int i;
#ifdef TCL_COMPILE_STATS
| > > > | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 |
*/
void
TclCleanupByteCode(codePtr)
register ByteCode *codePtr; /* Points to the ByteCode to free. */
{
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
#ifdef TCL_TIP280
Interp* iPtr = (Interp*) interp;
#endif
int numLitObjects = codePtr->numLitObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
register Tcl_Obj **objArrayPtr;
register AuxData *auxDataPtr;
int i;
#ifdef TCL_COMPILE_STATS
|
| ︙ | ︙ | |||
658 659 660 661 662 663 664 665 666 667 668 669 670 671 |
auxDataPtr = codePtr->auxDataArrayPtr;
for (i = 0; i < numAuxDataItems; i++) {
if (auxDataPtr->type->freeProc != NULL) {
(*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
}
auxDataPtr++;
}
TclHandleRelease(codePtr->interpHandle);
ckfree((char *) codePtr);
}
/*
*----------------------------------------------------------------------
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 |
auxDataPtr = codePtr->auxDataArrayPtr;
for (i = 0; i < numAuxDataItems; i++) {
if (auxDataPtr->type->freeProc != NULL) {
(*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
}
auxDataPtr++;
}
#ifdef TCL_TIP280
/*
* TIP #280. Release the location data associated with this byte code
* structure, if any. NOTE: The interp we belong to may be gone already,
* and the data with it.
*
* See also tclBasic.c, DeleteInterpProc
*/
if (iPtr) {
Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
if (hePtr) {
ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
int i;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (eclPtr->path);
}
for (i=0; i< eclPtr->nuloc; i++) {
ckfree ((char*) eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
ckfree ((char*) eclPtr->loc);
}
ckfree ((char*) eclPtr);
Tcl_DeleteHashEntry (hePtr);
}
}
#endif
TclHandleRelease(codePtr->interpHandle);
ckfree((char *) codePtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 |
* Side effects:
* The CompileEnv structure is initialized.
*
*----------------------------------------------------------------------
*/
void
TclInitCompileEnv(interp, envPtr, string, numBytes)
Tcl_Interp *interp; /* The interpreter for which a CompileEnv
* structure is initialized. */
register CompileEnv *envPtr; /* Points to the CompileEnv structure to
* initialize. */
char *string; /* The source string to be compiled. */
int numBytes; /* Number of bytes in source string. */
{
Interp *iPtr = (Interp *) interp;
envPtr->iPtr = iPtr;
envPtr->source = string;
envPtr->numSrcBytes = numBytes;
envPtr->procPtr = iPtr->compiledProcPtr;
| > > > > > > > > > | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 |
* Side effects:
* The CompileEnv structure is initialized.
*
*----------------------------------------------------------------------
*/
void
#ifndef TCL_TIP280
TclInitCompileEnv(interp, envPtr, string, numBytes)
#else
TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
#endif
Tcl_Interp *interp; /* The interpreter for which a CompileEnv
* structure is initialized. */
register CompileEnv *envPtr; /* Points to the CompileEnv structure to
* initialize. */
char *string; /* The source string to be compiled. */
int numBytes; /* Number of bytes in source string. */
#ifdef TCL_TIP280
CONST CmdFrame* invoker; /* Location context invoking the bcc */
int word; /* Index of the word in that context
* getting compiled */
#endif
{
Interp *iPtr = (Interp *) interp;
envPtr->iPtr = iPtr;
envPtr->source = string;
envPtr->numSrcBytes = numBytes;
envPtr->procPtr = iPtr->compiledProcPtr;
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
envPtr->exceptArrayNext = 0;
envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
envPtr->mallocedExceptArray = 0;
envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
envPtr->mallocedCmdMap = 0;
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 |
envPtr->exceptArrayNext = 0;
envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
envPtr->mallocedExceptArray = 0;
envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
envPtr->mallocedCmdMap = 0;
#ifdef TCL_TIP280
/*
* TIP #280: Set up the extended command location information, based on
* the context invoking the byte code compiler. This structure is used to
* keep the per-word line information for all compiled commands.
*
* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
* non-compiling evaluator
*/
envPtr->extCmdMapPtr = (ExtCmdLoc*) ckalloc (sizeof (ExtCmdLoc));
envPtr->extCmdMapPtr->loc = NULL;
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
envPtr->extCmdMapPtr->path = NULL;
if (invoker == NULL) {
/* Initialize the compiler for relative counting */
envPtr->line = 1;
envPtr->extCmdMapPtr->type = (envPtr->procPtr
? TCL_LOCATION_PROC
: TCL_LOCATION_BC);
} else {
/* Initialize the compiler using the context, making counting absolute
* to that context. Note that the context can be byte code
* execution. In that case we have to fill out the missing pieces
* (line, path, ...). Which may make change the type as well.
*/
if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
/* Word is not a literal, relative counting */
envPtr->line = 1;
envPtr->extCmdMapPtr->type = (envPtr->procPtr
? TCL_LOCATION_PROC
: TCL_LOCATION_BC);
} else {
CmdFrame ctx = *invoker;
int pc = 0;
if (invoker->type == TCL_LOCATION_BC) {
/* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr is used instead.
*/
TclGetSrcInfoForPc (&ctx);
pc = 1;
}
envPtr->line = ctx.line [word];
envPtr->extCmdMapPtr->type = ctx.type;
if (ctx.type == TCL_LOCATION_SOURCE) {
if (pc) {
/* The reference 'TclGetSrcInfoForPc' made is transfered */
envPtr->extCmdMapPtr->path = ctx.data.eval.path;
ctx.data.eval.path = NULL;
} else {
/* We have a new reference here */
envPtr->extCmdMapPtr->path = ctx.data.eval.path;
Tcl_IncrRefCount (envPtr->extCmdMapPtr->path);
}
}
}
}
#endif
envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
envPtr->auxDataArrayNext = 0;
envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
envPtr->mallocedAuxDataArray = 0;
}
/*
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
if (envPtr->mallocedCmdMap) {
ckfree((char *) envPtr->cmdMapPtr);
}
if (envPtr->mallocedAuxDataArray) {
ckfree((char *) envPtr->auxDataArrayPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclCompileScript --
*
* Compile a Tcl script in a string.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 |
if (envPtr->mallocedCmdMap) {
ckfree((char *) envPtr->cmdMapPtr);
}
if (envPtr->mallocedAuxDataArray) {
ckfree((char *) envPtr->auxDataArrayPtr);
}
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
* TclWordKnownAtCompileTime --
*
* Test whether the value of a token is completely known at compile time.
*
* Results:
* Returns true if the tokenPtr argument points to a word value that is
* completely known at compile time. Generally, values that are known at
* compile time can be compiled to their values, while values that cannot
* be known until substitution at runtime must be compiled to bytecode
* instructions that perform that substitution. For several commands,
* whether or not arguments are known at compile time determine whether
* it is worthwhile to compile at all.
*
* Side effects:
* None.
*
* TIP #280
*----------------------------------------------------------------------
*/
int
TclWordKnownAtCompileTime (tokenPtr)
Tcl_Token* tokenPtr;
{
int i;
Tcl_Token* sub;
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {return 1;};
if (tokenPtr->type != TCL_TOKEN_WORD) {return 0;};
/* Check the sub tokens of the word. It is a literal if we find
* only BS and TEXT tokens */
for (i=0, sub = tokenPtr + 1;
i < tokenPtr->numComponents;
i++, sub ++) {
if (sub->type == TCL_TOKEN_TEXT) continue;
if (sub->type == TCL_TOKEN_BS) continue;
return 0;
}
return 1;
}
#endif
/*
*----------------------------------------------------------------------
*
* TclCompileScript --
*
* Compile a Tcl script in a string.
|
| ︙ | ︙ | |||
823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
CONST char *p, *next;
Namespace *cmdNsPtr;
Command *cmdPtr;
Tcl_Token *tokenPtr;
int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
int commandLength, objIndex, code;
Tcl_DString ds;
Tcl_DStringInit(&ds);
if (numBytes < 0) {
numBytes = strlen(script);
}
Tcl_ResetResult(interp);
isFirstCmd = 1;
/*
* Each iteration through the following loop compiles the next
* command from the script.
*/
p = script;
bytesLeft = numBytes;
gotParse = 0;
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
if (nested) {
| > > > > > > > > > > > | 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 |
CONST char *p, *next;
Namespace *cmdNsPtr;
Command *cmdPtr;
Tcl_Token *tokenPtr;
int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
int commandLength, objIndex, code;
Tcl_DString ds;
#ifdef TCL_TIP280
/* TIP #280 */
ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr;
int* wlines;
int wlineat, cmdLine;
#endif
Tcl_DStringInit(&ds);
if (numBytes < 0) {
numBytes = strlen(script);
}
Tcl_ResetResult(interp);
isFirstCmd = 1;
/*
* Each iteration through the following loop compiles the next
* command from the script.
*/
p = script;
bytesLeft = numBytes;
gotParse = 0;
#ifdef TCL_TIP280
cmdLine = envPtr->line;
#endif
do {
if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
code = TCL_ERROR;
goto error;
}
gotParse = 1;
if (nested) {
|
| ︙ | ︙ | |||
948 949 950 951 952 953 954 |
currCmdIndex = (envPtr->numCommands - 1);
if (!nested) {
lastTopLevelCmdIndex = currCmdIndex;
}
startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
EnterCmdStartData(envPtr, currCmdIndex,
(parse.commandStart - envPtr->source), startCodeOffset);
| | > > > > > > > > > > > > > > > > > > | 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 |
currCmdIndex = (envPtr->numCommands - 1);
if (!nested) {
lastTopLevelCmdIndex = currCmdIndex;
}
startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
EnterCmdStartData(envPtr, currCmdIndex,
(parse.commandStart - envPtr->source), startCodeOffset);
#ifdef TCL_TIP280
/* TIP #280. Scan the words and compute the extended location
* information. The map first contain full per-word line
* information for use by the compiler. This is later replaced by
* a reduced form which signals non-literal words, stored in
* 'wlines'.
*/
TclAdvanceLines (&cmdLine, p, parse.commandStart);
EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source),
parse.tokenPtr, parse.commandStart, parse.commandSize,
parse.numWords, cmdLine, &wlines);
wlineat = eclPtr->nuloc - 1;
#endif
for (wordIdx = 0, tokenPtr = parse.tokenPtr;
wordIdx < parse.numWords;
wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
#ifdef TCL_TIP280
envPtr->line = eclPtr->loc [wlineat].line [wordIdx];
#endif
if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* If this is the first word and the command has a
* compile procedure, let it compile the command.
*/
if (wordIdx == 0) {
|
| ︙ | ︙ | |||
985 986 987 988 989 990 991 992 993 994 995 996 |
Tcl_DStringValue(&ds),
(Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
if ((cmdPtr != NULL)
&& (cmdPtr->compileProc != NULL)
&& !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
code = (*(cmdPtr->compileProc))(interp, &parse,
envPtr);
if (code == TCL_OK) {
goto finishCommand;
} else if (code == TCL_OUT_LINE_COMPILE) {
| > > > > | > > > > > > | 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 |
Tcl_DStringValue(&ds),
(Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
if ((cmdPtr != NULL)
&& (cmdPtr->compileProc != NULL)
&& !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
int savedNumCmds = envPtr->numCommands;
unsigned int savedCodeNext =
envPtr->codeNext - envPtr->codeStart;
code = (*(cmdPtr->compileProc))(interp, &parse,
envPtr);
if (code == TCL_OK) {
goto finishCommand;
} else if (code == TCL_OUT_LINE_COMPILE) {
/*
* Restore numCommands and codeNext to their correct
* values, removing any commands compiled before
* TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055]
*/
envPtr->numCommands = savedNumCmds;
envPtr->codeNext = envPtr->codeStart + savedCodeNext;
} else { /* an error */
/*
* There was a compilation error, the last
* command did not get compiled into (*envPtr).
* Decrement the number of commands
* claimed to be in (*envPtr).
*/
|
| ︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 |
tokenPtr[1].start, tokenPtr[1].size);
}
TclEmitPush(objIndex, envPtr);
} else {
/*
* The word is not a simple string of characters.
*/
| < | 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 |
tokenPtr[1].start, tokenPtr[1].size);
}
TclEmitPush(objIndex, envPtr);
} else {
/*
* The word is not a simple string of characters.
*/
code = TclCompileTokens(interp, tokenPtr+1,
tokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
goto log;
}
}
}
|
| ︙ | ︙ | |||
1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 | * offsets of the source and code for the command. */ finishCommand: EnterCmdExtentData(envPtr, currCmdIndex, commandLength, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); isFirstCmd = 0; } /* end if parse.numWords > 0 */ /* * Advance to the next command in the script. */ | > > > > > > > > | > > > > | 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 |
* offsets of the source and code for the command.
*/
finishCommand:
EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
(envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
isFirstCmd = 0;
#ifdef TCL_TIP280
/* TIP #280: Free full form of per-word line data and insert
* the reduced form now
*/
ckfree ((char*) eclPtr->loc [wlineat].line);
eclPtr->loc [wlineat].line = wlines;
#endif
} /* end if parse.numWords > 0 */
/*
* Advance to the next command in the script.
*/
next = parse.commandStart + parse.commandSize;
bytesLeft -= (next - p);
p = next;
#ifdef TCL_TIP280
/* TIP #280 : Track lines in the just compiled command */
TclAdvanceLines (&cmdLine, parse.commandStart, p);
#endif
Tcl_FreeParse(&parse);
gotParse = 0;
if (nested && (*parse.term == ']')) {
/*
* We get here in the special case where TCL_BRACKET_TERM was
* set in the interpreter and the latest parsed command was
* terminated by the matching close-bracket we were looking for.
|
| ︙ | ︙ | |||
1451 1452 1453 1454 1455 1456 1457 |
int numBytes, i, code;
CONST char *script;
code = TCL_OK;
/*
* If the expression is a single word that doesn't require
| | < < < < < | 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 |
int numBytes, i, code;
CONST char *script;
code = TCL_OK;
/*
* If the expression is a single word that doesn't require
* substitutions, just compile its string into inline instructions.
*/
if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
script = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
code = TclCompileExpr(interp, script, numBytes, envPtr);
return code;
}
/*
|
| ︙ | ︙ | |||
1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 |
register CompileEnv *envPtr; /* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
register ByteCode *codePtr;
size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
size_t auxDataArrayBytes, structureSize;
register unsigned char *p;
unsigned char *nextPtr;
int numLitObjects = envPtr->literalArrayNext;
Namespace *namespacePtr;
int i;
Interp *iPtr;
iPtr = envPtr->iPtr;
codeBytes = (envPtr->codeNext - envPtr->codeStart);
objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
| > > > > > | 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 |
register CompileEnv *envPtr; /* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
register ByteCode *codePtr;
size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
size_t auxDataArrayBytes, structureSize;
register unsigned char *p;
#ifdef TCL_COMPILE_DEBUG
unsigned char *nextPtr;
#endif
int numLitObjects = envPtr->literalArrayNext;
Namespace *namespacePtr;
int i;
#ifdef TCL_TIP280
int new;
#endif
Interp *iPtr;
iPtr = envPtr->iPtr;
codeBytes = (envPtr->codeNext - envPtr->codeStart);
objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
|
| ︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 1624 |
memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
(size_t) auxDataArrayBytes);
} else {
codePtr->auxDataArrayPtr = NULL;
}
p += auxDataArrayBytes;
nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
| > > > < | 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 |
memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
(size_t) auxDataArrayBytes);
} else {
codePtr->auxDataArrayPtr = NULL;
}
p += auxDataArrayBytes;
#ifndef TCL_COMPILE_DEBUG
EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
#else
nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
if (((size_t)(nextPtr - p)) != cmdLocBytes) {
panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
}
#endif
/*
* Record various compilation-related statistics about the new ByteCode
|
| ︙ | ︙ | |||
1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 |
if ((objPtr->typePtr != NULL) &&
(objPtr->typePtr->freeIntRepProc != NULL)) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
objPtr->typePtr = &tclByteCodeType;
}
/*
*----------------------------------------------------------------------
*
* LogCompilationInfo --
*
| > > > > > > > > > > | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 |
if ((objPtr->typePtr != NULL) &&
(objPtr->typePtr->freeIntRepProc != NULL)) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
objPtr->typePtr = &tclByteCodeType;
#ifdef TCL_TIP280
/* TIP #280. Associate the extended per-word line information with the
* byte code object (internal rep), for use with the bc compiler.
*/
Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->lineBCPtr, (char*) codePtr, &new),
envPtr->extCmdMapPtr);
envPtr->extCmdMapPtr = NULL;
#endif
}
/*
*----------------------------------------------------------------------
*
* LogCompilationInfo --
*
|
| ︙ | ︙ | |||
1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 |
if (length < 0) {
length = strlen(command);
}
if (length > 150) {
length = 150;
ellipsis = "...";
}
sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
length, command, ellipsis);
Tcl_AddObjErrorInfo(interp, buffer, -1);
}
/*
| > > > > > > > > | 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 |
if (length < 0) {
length = strlen(command);
}
if (length > 150) {
length = 150;
ellipsis = "...";
}
while ( (command[length] & 0xC0) == 0x80 ) {
/*
* Back up truncation point so that we don't truncate in the
* middle of a multi-byte character (in UTF-8)
*/
length--;
ellipsis = "...";
}
sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
length, command, ellipsis);
Tcl_AddObjErrorInfo(interp, buffer, -1);
}
/*
|
| ︙ | ︙ | |||
2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 |
cmdIndex);
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
cmdLocPtr->numSrcBytes = numSrcBytes;
cmdLocPtr->numCodeBytes = numCodeBytes;
}
/*
*----------------------------------------------------------------------
*
* TclCreateExceptRange --
*
* Procedure that allocates and initializes a new ExceptionRange
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 |
cmdIndex);
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
cmdLocPtr->numSrcBytes = numSrcBytes;
cmdLocPtr->numCodeBytes = numCodeBytes;
}
#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
* TIP #280
*
* EnterCmdWordData --
*
* Registers the lines for the words of a command. This information
* is used at runtime by 'info frame'.
*
* Results:
* None.
*
* Side effects:
* Inserts word location information into the compilation
* environment envPtr for the command at index cmdIndex. The
* compilation environment's ExtCmdLoc.ECL array is grown if necessary.
*
*----------------------------------------------------------------------
*/
static void
EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines)
ExtCmdLoc *eclPtr; /* Points to the map environment
* structure in which to enter command
* location information. */
int srcOffset; /* Offset of first char of the command. */
Tcl_Token* tokenPtr;
CONST char* cmd;
int len;
int numWords;
int line;
int** wlines;
{
ECL* ePtr;
int wordIdx;
CONST char* last;
int wordLine;
int* wwlines;
if (eclPtr->nuloc >= eclPtr->nloc) {
/*
* Expand the ECL array by allocating more storage from the
* heap. The currently allocated ECL entries are stored from
* eclPtr->loc[0] up to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
*/
size_t currElems = eclPtr->nloc;
size_t newElems = (currElems ? 2*currElems : 1);
size_t currBytes = currElems * sizeof(ECL);
size_t newBytes = newElems * sizeof(ECL);
ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes);
/*
* Copy from old ECL array to new, free old ECL array if
* needed.
*/
if (currBytes) {
memcpy((VOID *) newPtr, (VOID *) eclPtr->loc, currBytes);
}
if (eclPtr->loc != NULL) {
ckfree((char *) eclPtr->loc);
}
eclPtr->loc = (ECL *) newPtr;
eclPtr->nloc = newElems;
}
ePtr = &eclPtr->loc [eclPtr->nuloc];
ePtr->srcOffset = srcOffset;
ePtr->line = (int*) ckalloc (numWords * sizeof (int));
ePtr->nline = numWords;
wwlines = (int*) ckalloc (numWords * sizeof (int));
last = cmd;
wordLine = line;
for (wordIdx = 0;
wordIdx < numWords;
wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
TclAdvanceLines (&wordLine, last, tokenPtr->start);
wwlines [wordIdx] = (TclWordKnownAtCompileTime (tokenPtr)
? wordLine
: -1);
ePtr->line [wordIdx] = wordLine;
last = tokenPtr->start;
}
*wlines = wwlines;
eclPtr->nuloc ++;
}
#endif
/*
*----------------------------------------------------------------------
*
* TclCreateExceptRange --
*
* Procedure that allocates and initializes a new ExceptionRange
|
| ︙ | ︙ | |||
3462 3463 3464 3465 3466 3467 3468 |
statsPtr->currentExceptBytes +=
(double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
statsPtr->currentAuxBytes +=
(double) (codePtr->numAuxDataItems * sizeof(AuxData));
statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
}
#endif /* TCL_COMPILE_STATS */
| > > > > > > > > > | 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 |
statsPtr->currentExceptBytes +=
(double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
statsPtr->currentAuxBytes +=
(double) (codePtr->numAuxDataItems * sizeof(AuxData));
statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
}
#endif /* TCL_COMPILE_STATS */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCompile.h.
1 2 3 4 5 6 7 8 9 10 | /* * tclCompile.h -- * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclCompile.h -- * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclCompile.h,v 1.33.2.1 2006/11/28 22:20:00 andreas_kupries Exp $ */ #ifndef _TCLCOMPILATION #define _TCLCOMPILATION 1 #ifndef _TCLINT #include "tclInt.h" |
| ︙ | ︙ | |||
116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
typedef struct CmdLocation {
int codeOffset; /* Offset of first byte of command code. */
int numCodeBytes; /* Number of bytes for command's code. */
int srcOffset; /* Offset of first char of the command. */
int numSrcBytes; /* Number of command source chars. */
} CmdLocation;
/*
* CompileProcs need the ability to record information during compilation
* that can be used by bytecode instructions during execution. The AuxData
* structure provides this "auxiliary data" mechanism. An arbitrary number
* of these structures can be stored in the ByteCode record (during
* compilation they are stored in a CompileEnv structure). Each AuxData
| > > > > > > > > > > > > > > > > > > > > > > > > > > > | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
typedef struct CmdLocation {
int codeOffset; /* Offset of first byte of command code. */
int numCodeBytes; /* Number of bytes for command's code. */
int srcOffset; /* Offset of first char of the command. */
int numSrcBytes; /* Number of command source chars. */
} CmdLocation;
#ifdef TCL_TIP280
/*
* TIP #280
* Structure to record additional location information for byte code.
* This information is internal and not saved. I.e. tbcload'ed code
* will not have this information. It records the lines for all words
* of all commands found in the byte code. The association with a
* ByteCode structure BC is done through the 'lineBCPtr' HashTable in
* Interp, keyed by the address of BC. Also recorded is information
* coming from the context, i.e. type of the frame and associated
* information, like the path of a sourced file.
*/
typedef struct ECL {
int srcOffset; /* cmd location to find the entry */
int nline;
int* line; /* line information for all words in the command */
} ECL;
typedef struct ExtCmdLoc {
int type; /* Context type */
Tcl_Obj* path; /* Path of the sourced file the command is in */
ECL* loc; /* Command word locations (lines) */
int nloc; /* Number of allocated entries in 'loc' */
int nuloc; /* Number of used entries in 'loc' */
} ExtCmdLoc;
#endif
/*
* CompileProcs need the ability to record information during compilation
* that can be used by bytecode instructions during execution. The AuxData
* structure provides this "auxiliary data" mechanism. An arbitrary number
* of these structures can be stored in the ByteCode record (during
* compilation they are stored in a CompileEnv structure). Each AuxData
|
| ︙ | ︙ | |||
260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
/* Initial storage of LiteralEntry array. */
ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
/* Initial ExceptionRange array storage. */
CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
/* Initial storage for cmd location map. */
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
/* Initial storage for aux data array. */
} CompileEnv;
/*
* The structure defining the bytecode instructions resulting from compiling
* a Tcl script. Note that this structure is variable length: a single heap
* object is allocated to hold the ByteCode structure immediately followed
* by the code bytes, the literal object array, the ExceptionRange array,
| > > > > > > > > | 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 |
/* Initial storage of LiteralEntry array. */
ExceptionRange staticExceptArraySpace[COMPILEENV_INIT_EXCEPT_RANGES];
/* Initial ExceptionRange array storage. */
CmdLocation staticCmdMapSpace[COMPILEENV_INIT_CMD_MAP_SIZE];
/* Initial storage for cmd location map. */
AuxData staticAuxDataArraySpace[COMPILEENV_INIT_AUX_DATA_SIZE];
/* Initial storage for aux data array. */
#ifdef TCL_TIP280
/* TIP #280 */
ExtCmdLoc* extCmdMapPtr; /* Extended command location information
* for 'info frame'. */
int line; /* First line of the script, based on the
* invoking context, then the line of the
* command currently compiled. */
#endif
} CompileEnv;
/*
* The structure defining the bytecode instructions resulting from compiling
* a Tcl script. Note that this structure is variable length: a single heap
* object is allocated to hold the ByteCode structure immediately followed
* by the code bytes, the literal object array, the ExceptionRange array,
|
| ︙ | ︙ | |||
723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 | /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c *---------------------------------------------------------------- */ EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); /* *---------------------------------------------------------------- * Procedures shared among Tcl bytecode compilation and execution * modules but not used outside: *---------------------------------------------------------------- */ | > > > > > > | 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 | /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c *---------------------------------------------------------------- */ #ifndef TCL_TIP280 EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); #else EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, CONST CmdFrame* invoker, int word)); #endif /* *---------------------------------------------------------------- * Procedures shared among Tcl bytecode compilation and execution * modules but not used outside: *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 | EXTERN void TclFreeCompileEnv _ANSI_ARGS_((CompileEnv *envPtr)); EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); EXTERN void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); EXTERN void TclInitCompilation _ANSI_ARGS_((void)); EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, CompileEnv *envPtr, char *string, int numBytes)); EXTERN void TclInitJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); EXTERN void TclInitLiteralTable _ANSI_ARGS_(( LiteralTable *tablePtr)); #ifdef TCL_COMPILE_STATS EXTERN char * TclLiteralStats _ANSI_ARGS_(( LiteralTable *tablePtr)); | > > > > > > | 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 | EXTERN void TclFreeCompileEnv _ANSI_ARGS_((CompileEnv *envPtr)); EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); EXTERN void TclInitAuxDataTypeTable _ANSI_ARGS_((void)); EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr, CompileEnv *envPtr)); EXTERN void TclInitCompilation _ANSI_ARGS_((void)); #ifndef TCL_TIP280 EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, CompileEnv *envPtr, char *string, int numBytes)); #else EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp, CompileEnv *envPtr, char *string, int numBytes, CONST CmdFrame* invoker, int word)); #endif EXTERN void TclInitJumpFixupArray _ANSI_ARGS_(( JumpFixupArray *fixupArrayPtr)); EXTERN void TclInitLiteralTable _ANSI_ARGS_(( LiteralTable *tablePtr)); #ifdef TCL_COMPILE_STATS EXTERN char * TclLiteralStats _ANSI_ARGS_(( LiteralTable *tablePtr)); |
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 | #define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLCOMPILATION */ | < < < < < | 1082 1083 1084 1085 1086 1087 1088 | #define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) #define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLIMPORT #endif /* _TCLCOMPILATION */ |
Changes to generic/tclDate.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclDate.c -- * * This file is generated from a yacc grammar defined in * the file tclGetDate.y. It should not be edited directly. * * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclDate.c -- * * This file is generated from a yacc grammar defined in * the file tclGetDate.y. It should not be edited directly. * * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclDate.c,v 1.20.4.3 2006/06/14 15:21:14 patthoyts Exp $ */ #include "tclInt.h" #include "tclPort.h" #if defined(MAC_TCL) && !defined(TCL_MAC_USE_MSL_EPOCH) # define EPOCH 1904 |
| ︙ | ︙ | |||
330 331 332 333 334 335 336 337 338 339 340 341 342 343 |
{ "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */
#endif /* 0 */
{ "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */
{ "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
{ "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
{ "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
{ "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
{ "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
{ "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
{ "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
{ "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
{ "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */
{ "nzt", tZONE, -HOUR(12) }, /* New Zealand */
{ "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */
| > > > | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
{ "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */
#endif /* 0 */
{ "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */
{ "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
{ "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
{ "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
{ "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
{ "jdt", tDAYZONE, -HOUR( 9) }, /* Japan Daylight */
{ "kst", tZONE, -HOUR( 9) }, /* Korea Standard */
{ "kdt", tDAYZONE, -HOUR( 9) }, /* Korea Daylight */
{ "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
{ "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
{ "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
{ "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
{ "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */
{ "nzt", tZONE, -HOUR(12) }, /* New Zealand */
{ "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */
|
| ︙ | ︙ | |||
471 472 473 474 475 476 477 |
*/
for (Julian = Day - 1, i = 0; i < Month; i++)
Julian += DaysInMonth[i];
if (Year >= EPOCH) {
for (i = EPOCH; i < Year; i++)
Julian += 365 + IsLeapYear(i);
} else {
| | | 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 |
*/
for (Julian = Day - 1, i = 0; i < Month; i++)
Julian += DaysInMonth[i];
if (Year >= EPOCH) {
for (i = EPOCH; i < Year; i++)
Julian += 365 + IsLeapYear(i);
} else {
for (i = (int)Year; i < EPOCH; i++)
Julian -= 365 + IsLeapYear(i);
}
Julian *= SECSPERDAY;
/* Add the timezone offset ?? */
Julian += TclDateTimezone * 60L;
|
| ︙ | ︙ | |||
540 541 542 543 544 545 546 |
tm = TclpGetDate((TclpTime_t)&now, 0);
/* To compute the next n'th month, we use this alg:
* add n to year value
* if currentMonth < requestedMonth decrement year value by 1 (so that
* doing next february from january gives us february of the current year)
* set day to 1, time to 0
*/
| | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 |
tm = TclpGetDate((TclpTime_t)&now, 0);
/* To compute the next n'th month, we use this alg:
* add n to year value
* if currentMonth < requestedMonth decrement year value by 1 (so that
* doing next february from january gives us february of the current year)
* set day to 1, time to 0
*/
tm->tm_year += (int)MonthOrdinal;
if (tm->tm_mon < MonthNumber - 1) {
tm->tm_year--;
}
result = Convert(MonthNumber, (time_t) 1, tm->tm_year + TM_YEAR_BASE,
(time_t) 0, (time_t) 0, (time_t) 0, MER24, DSTmaybe, &now);
if (result < 0) {
return 0;
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 |
/*
* Specify zone is of -50000 to force GMT. (This allows BST to work).
*/
int
TclGetDate(p, now, zone, timePtr)
char *p;
| | | | | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 |
/*
* Specify zone is of -50000 to force GMT. (This allows BST to work).
*/
int
TclGetDate(p, now, zone, timePtr)
char *p;
Tcl_WideInt now;
long zone;
Tcl_WideInt *timePtr;
{
struct tm *tm;
time_t Start;
time_t Time;
time_t tod;
int thisyear;
TclDateInput = p;
/* now has to be cast to a time_t for 64bit compliance */
Start = (time_t) now;
tm = TclpGetDate((TclpTime_t) &Start, (zone == -50000));
thisyear = tm->tm_year + TM_YEAR_BASE;
TclDateYear = thisyear;
TclDateMonth = tm->tm_mon + 1;
TclDateDay = tm->tm_mday;
TclDateTimezone = zone;
if (zone == -50000) {
TclDateDSTmode = DSToff; /* assume GMT */
|
| ︙ | ︙ | |||
900 901 902 903 904 905 906 |
}
}
if (Convert(TclDateMonth, TclDateDay, TclDateYear, TclDateHour, TclDateMinutes, TclDateSeconds,
TclDateMeridian, TclDateDSTmode, &Start) < 0) {
return -1;
}
} else {
| | | 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
}
}
if (Convert(TclDateMonth, TclDateDay, TclDateYear, TclDateHour, TclDateMinutes, TclDateSeconds,
TclDateMeridian, TclDateDSTmode, &Start) < 0) {
return -1;
}
} else {
Start = (time_t) now;
if (!TclDateHaveRel) {
Start -= ((tm->tm_hour * 60L * 60L) +
tm->tm_min * 60L) + tm->tm_sec;
}
}
Start += TclDateRelSeconds;
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
1 2 3 4 5 6 7 8 9 10 | /* * tclDecls.h -- * * Declarations of functions in the platform independent public Tcl API. * * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclDecls.h -- * * Declarations of functions in the platform independent public Tcl API. * * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclDecls.h,v 1.93.2.7 2006/09/22 01:26:23 andreas_kupries Exp $ */ #ifndef _TCLDECLS #define _TCLDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl |
| ︙ | ︙ | |||
1301 1302 1303 1304 1305 1306 1307 | /* 410 */ EXTERN Tcl_DriverFlushProc * Tcl_ChannelFlushProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); /* 411 */ EXTERN Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); /* 412 */ | | | 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 | /* 410 */ EXTERN Tcl_DriverFlushProc * Tcl_ChannelFlushProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); /* 411 */ EXTERN Tcl_DriverHandlerProc * Tcl_ChannelHandlerProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); /* 412 */ EXTERN int Tcl_JoinThread _ANSI_ARGS_((Tcl_ThreadId threadId, int* result)); /* 413 */ EXTERN int Tcl_IsChannelShared _ANSI_ARGS_((Tcl_Channel channel)); /* 414 */ EXTERN int Tcl_IsChannelRegistered _ANSI_ARGS_(( Tcl_Interp* interp, Tcl_Channel channel)); /* 415 */ |
| ︙ | ︙ | |||
1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 |
EXTERN Tcl_WideInt Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan,
Tcl_WideInt offset, int mode));
/* 492 */
EXTERN Tcl_WideInt Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan));
/* 493 */
EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc _ANSI_ARGS_((
Tcl_ChannelType * chanTypePtr));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
struct TclIntStubs *tclIntStubs;
struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 |
EXTERN Tcl_WideInt Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan,
Tcl_WideInt offset, int mode));
/* 492 */
EXTERN Tcl_WideInt Tcl_Tell _ANSI_ARGS_((Tcl_Channel chan));
/* 493 */
EXTERN Tcl_DriverWideSeekProc * Tcl_ChannelWideSeekProc _ANSI_ARGS_((
Tcl_ChannelType * chanTypePtr));
/* Slot 494 is reserved */
/* Slot 495 is reserved */
/* Slot 496 is reserved */
/* Slot 497 is reserved */
/* Slot 498 is reserved */
/* Slot 499 is reserved */
/* Slot 500 is reserved */
/* Slot 501 is reserved */
/* Slot 502 is reserved */
/* Slot 503 is reserved */
/* Slot 504 is reserved */
/* Slot 505 is reserved */
/* Slot 506 is reserved */
/* Slot 507 is reserved */
/* Slot 508 is reserved */
/* Slot 509 is reserved */
/* Slot 510 is reserved */
/* Slot 511 is reserved */
/* Slot 512 is reserved */
/* Slot 513 is reserved */
/* Slot 514 is reserved */
/* Slot 515 is reserved */
/* Slot 516 is reserved */
/* Slot 517 is reserved */
/* Slot 518 is reserved */
/* Slot 519 is reserved */
/* Slot 520 is reserved */
/* Slot 521 is reserved */
/* Slot 522 is reserved */
/* Slot 523 is reserved */
/* Slot 524 is reserved */
/* Slot 525 is reserved */
/* Slot 526 is reserved */
/* Slot 527 is reserved */
/* Slot 528 is reserved */
/* Slot 529 is reserved */
/* Slot 530 is reserved */
/* Slot 531 is reserved */
/* Slot 532 is reserved */
/* Slot 533 is reserved */
/* Slot 534 is reserved */
/* Slot 535 is reserved */
/* Slot 536 is reserved */
/* Slot 537 is reserved */
/* Slot 538 is reserved */
/* Slot 539 is reserved */
/* Slot 540 is reserved */
/* Slot 541 is reserved */
/* Slot 542 is reserved */
/* Slot 543 is reserved */
/* Slot 544 is reserved */
/* Slot 545 is reserved */
/* Slot 546 is reserved */
/* Slot 547 is reserved */
/* Slot 548 is reserved */
/* Slot 549 is reserved */
/* Slot 550 is reserved */
/* Slot 551 is reserved */
/* Slot 552 is reserved */
/* Slot 553 is reserved */
/* 554 */
EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc _ANSI_ARGS_((
Tcl_ChannelType * chanTypePtr));
/* Slot 555 is reserved */
/* Slot 556 is reserved */
/* Slot 557 is reserved */
/* Slot 558 is reserved */
/* Slot 559 is reserved */
/* Slot 560 is reserved */
/* Slot 561 is reserved */
/* Slot 562 is reserved */
/* Slot 563 is reserved */
/* Slot 564 is reserved */
/* Slot 565 is reserved */
/* Slot 566 is reserved */
/* Slot 567 is reserved */
/* Slot 568 is reserved */
/* Slot 569 is reserved */
/* Slot 570 is reserved */
/* Slot 571 is reserved */
/* Slot 572 is reserved */
/* 573 */
EXTERN int Tcl_PkgRequireProc _ANSI_ARGS_((Tcl_Interp * interp,
CONST char * name, int objc,
Tcl_Obj *CONST objv[],
ClientData * clientDataPtr));
typedef struct TclStubHooks {
struct TclPlatStubs *tclPlatStubs;
struct TclIntStubs *tclIntStubs;
struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
|
| ︙ | ︙ | |||
2031 2032 2033 2034 2035 2036 2037 |
Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 405 */
Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 406 */
Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 407 */
Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 408 */
Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 409 */
Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 410 */
Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 411 */
| | | 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 |
Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 405 */
Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 406 */
Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 407 */
Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 408 */
Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 409 */
Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 410 */
Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 411 */
int (*tcl_JoinThread) _ANSI_ARGS_((Tcl_ThreadId threadId, int* result)); /* 412 */
int (*tcl_IsChannelShared) _ANSI_ARGS_((Tcl_Channel channel)); /* 413 */
int (*tcl_IsChannelRegistered) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 414 */
void (*tcl_CutChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 415 */
void (*tcl_SpliceChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 416 */
void (*tcl_ClearChannelHandlers) _ANSI_ARGS_((Tcl_Channel channel)); /* 417 */
int (*tcl_IsChannelExisting) _ANSI_ARGS_((CONST char* channelName)); /* 418 */
int (*tcl_UniCharNcasecmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 419 */
|
| ︙ | ︙ | |||
2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 |
int (*tcl_GetWideIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_WideInt * widePtr)); /* 487 */
Tcl_Obj * (*tcl_NewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue)); /* 488 */
void (*tcl_SetWideIntObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_WideInt wideValue)); /* 489 */
Tcl_StatBuf * (*tcl_AllocStatBuf) _ANSI_ARGS_((void)); /* 490 */
Tcl_WideInt (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt offset, int mode)); /* 491 */
Tcl_WideInt (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 492 */
Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 493 */
} TclStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclStubs *tclStubsPtr;
#ifdef __cplusplus
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 |
int (*tcl_GetWideIntFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_WideInt * widePtr)); /* 487 */
Tcl_Obj * (*tcl_NewWideIntObj) _ANSI_ARGS_((Tcl_WideInt wideValue)); /* 488 */
void (*tcl_SetWideIntObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_WideInt wideValue)); /* 489 */
Tcl_StatBuf * (*tcl_AllocStatBuf) _ANSI_ARGS_((void)); /* 490 */
Tcl_WideInt (*tcl_Seek) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt offset, int mode)); /* 491 */
Tcl_WideInt (*tcl_Tell) _ANSI_ARGS_((Tcl_Channel chan)); /* 492 */
Tcl_DriverWideSeekProc * (*tcl_ChannelWideSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 493 */
void *reserved494;
void *reserved495;
void *reserved496;
void *reserved497;
void *reserved498;
void *reserved499;
void *reserved500;
void *reserved501;
void *reserved502;
void *reserved503;
void *reserved504;
void *reserved505;
void *reserved506;
void *reserved507;
void *reserved508;
void *reserved509;
void *reserved510;
void *reserved511;
void *reserved512;
void *reserved513;
void *reserved514;
void *reserved515;
void *reserved516;
void *reserved517;
void *reserved518;
void *reserved519;
void *reserved520;
void *reserved521;
void *reserved522;
void *reserved523;
void *reserved524;
void *reserved525;
void *reserved526;
void *reserved527;
void *reserved528;
void *reserved529;
void *reserved530;
void *reserved531;
void *reserved532;
void *reserved533;
void *reserved534;
void *reserved535;
void *reserved536;
void *reserved537;
void *reserved538;
void *reserved539;
void *reserved540;
void *reserved541;
void *reserved542;
void *reserved543;
void *reserved544;
void *reserved545;
void *reserved546;
void *reserved547;
void *reserved548;
void *reserved549;
void *reserved550;
void *reserved551;
void *reserved552;
void *reserved553;
Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 554 */
void *reserved555;
void *reserved556;
void *reserved557;
void *reserved558;
void *reserved559;
void *reserved560;
void *reserved561;
void *reserved562;
void *reserved563;
void *reserved564;
void *reserved565;
void *reserved566;
void *reserved567;
void *reserved568;
void *reserved569;
void *reserved570;
void *reserved571;
void *reserved572;
int (*tcl_PkgRequireProc) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, int objc, Tcl_Obj *CONST objv[], ClientData * clientDataPtr)); /* 573 */
} TclStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclStubs *tclStubsPtr;
#ifdef __cplusplus
|
| ︙ | ︙ | |||
4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 | #define Tcl_Tell \ (tclStubsPtr->tcl_Tell) /* 492 */ #endif #ifndef Tcl_ChannelWideSeekProc #define Tcl_ChannelWideSeekProc \ (tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLDECLS */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 | #define Tcl_Tell \ (tclStubsPtr->tcl_Tell) /* 492 */ #endif #ifndef Tcl_ChannelWideSeekProc #define Tcl_ChannelWideSeekProc \ (tclStubsPtr->tcl_ChannelWideSeekProc) /* 493 */ #endif /* Slot 494 is reserved */ /* Slot 495 is reserved */ /* Slot 496 is reserved */ /* Slot 497 is reserved */ /* Slot 498 is reserved */ /* Slot 499 is reserved */ /* Slot 500 is reserved */ /* Slot 501 is reserved */ /* Slot 502 is reserved */ /* Slot 503 is reserved */ /* Slot 504 is reserved */ /* Slot 505 is reserved */ /* Slot 506 is reserved */ /* Slot 507 is reserved */ /* Slot 508 is reserved */ /* Slot 509 is reserved */ /* Slot 510 is reserved */ /* Slot 511 is reserved */ /* Slot 512 is reserved */ /* Slot 513 is reserved */ /* Slot 514 is reserved */ /* Slot 515 is reserved */ /* Slot 516 is reserved */ /* Slot 517 is reserved */ /* Slot 518 is reserved */ /* Slot 519 is reserved */ /* Slot 520 is reserved */ /* Slot 521 is reserved */ /* Slot 522 is reserved */ /* Slot 523 is reserved */ /* Slot 524 is reserved */ /* Slot 525 is reserved */ /* Slot 526 is reserved */ /* Slot 527 is reserved */ /* Slot 528 is reserved */ /* Slot 529 is reserved */ /* Slot 530 is reserved */ /* Slot 531 is reserved */ /* Slot 532 is reserved */ /* Slot 533 is reserved */ /* Slot 534 is reserved */ /* Slot 535 is reserved */ /* Slot 536 is reserved */ /* Slot 537 is reserved */ /* Slot 538 is reserved */ /* Slot 539 is reserved */ /* Slot 540 is reserved */ /* Slot 541 is reserved */ /* Slot 542 is reserved */ /* Slot 543 is reserved */ /* Slot 544 is reserved */ /* Slot 545 is reserved */ /* Slot 546 is reserved */ /* Slot 547 is reserved */ /* Slot 548 is reserved */ /* Slot 549 is reserved */ /* Slot 550 is reserved */ /* Slot 551 is reserved */ /* Slot 552 is reserved */ /* Slot 553 is reserved */ #ifndef Tcl_ChannelThreadActionProc #define Tcl_ChannelThreadActionProc \ (tclStubsPtr->tcl_ChannelThreadActionProc) /* 554 */ #endif /* Slot 555 is reserved */ /* Slot 556 is reserved */ /* Slot 557 is reserved */ /* Slot 558 is reserved */ /* Slot 559 is reserved */ /* Slot 560 is reserved */ /* Slot 561 is reserved */ /* Slot 562 is reserved */ /* Slot 563 is reserved */ /* Slot 564 is reserved */ /* Slot 565 is reserved */ /* Slot 566 is reserved */ /* Slot 567 is reserved */ /* Slot 568 is reserved */ /* Slot 569 is reserved */ /* Slot 570 is reserved */ /* Slot 571 is reserved */ /* Slot 572 is reserved */ #ifndef Tcl_PkgRequireProc #define Tcl_PkgRequireProc \ (tclStubsPtr->tcl_PkgRequireProc) /* 573 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLDECLS */ |
Changes to generic/tclEncoding.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclEncoding.c -- * * Contains the implementation of the encoding conversion package. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclEncoding.c,v 1.16.2.14 2007/02/12 19:25:42 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclPort.h" typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src)); |
| ︙ | ︙ | |||
174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 | */ static int BinaryProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static void EscapeFreeProc _ANSI_ARGS_((ClientData clientData)); static int EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); static Encoding * GetTableEncoding _ANSI_ARGS_(( EscapeEncodingData *dataPtr, int state)); static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, int type, Tcl_Channel chan)); static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, | > > > | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 | */ static int BinaryProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static void DupEncodingIntRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); static void EscapeFreeProc _ANSI_ARGS_((ClientData clientData)); static int EscapeFromUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static int EscapeToUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static void FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); static void FreeEncodingIntRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static Encoding * GetTableEncoding _ANSI_ARGS_(( EscapeEncodingData *dataPtr, int state)); static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name, int type, Tcl_Channel chan)); static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, |
| ︙ | ︙ | |||
222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); static int UtfToUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)); /* *--------------------------------------------------------------------------- * * TclInitEncodingSubsystem -- * * Initialize all resources used by this subsystem on a per-process | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int UtfToUtfProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr, int pureNullMode));
static int UtfIntToUtfExtProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int UtfExtToUtfIntProc _ANSI_ARGS_((ClientData clientData,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr,
int *dstCharsPtr));
static int TclFindEncodings _ANSI_ARGS_((CONST char *argv0));
/*
* A Tcl_ObjType for holding a cached Tcl_Encoding as the intrep.
* This should help the lifetime of encodings be more useful.
* See concerns raised in [Bug 1077262].
*/
static Tcl_ObjType EncodingType = {
"encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL
};
/*
*----------------------------------------------------------------------
*
* TclGetEncodingFromObj --
*
* Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr),
* if possible, and returns TCL_OK. If no such encoding exists,
* TCL_ERROR is returned, and if interp is non-NULL, an error message
* is written there.
*
* Results:
* Standard Tcl return code.
*
* Side effects:
* Caches the Tcl_Encoding value as the internal rep of (*objPtr).
*
*----------------------------------------------------------------------
*/
int
TclGetEncodingFromObj(interp, objPtr, encodingPtr)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
Tcl_Encoding *encodingPtr;
{
CONST char *name = Tcl_GetString(objPtr);
if (objPtr->typePtr != &EncodingType) {
Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
if (encoding == NULL) {
return TCL_ERROR;
}
if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) {
objPtr->typePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.otherValuePtr = (VOID *) encoding;
objPtr->typePtr = &EncodingType;
}
*encodingPtr = Tcl_GetEncoding(NULL, name);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeEncodingIntRep --
*
* The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static void
FreeEncodingIntRep(objPtr)
Tcl_Obj *objPtr;
{
Tcl_FreeEncoding((Tcl_Encoding) objPtr->internalRep.otherValuePtr);
}
/*
*----------------------------------------------------------------------
*
* DupEncodingIntRep --
*
* The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static void
DupEncodingIntRep(srcPtr, dupPtr)
Tcl_Obj *srcPtr;
Tcl_Obj *dupPtr;
{
dupPtr->internalRep.otherValuePtr = (VOID *)
Tcl_GetEncoding(NULL, srcPtr->bytes);
}
/*
*---------------------------------------------------------------------------
*
* TclInitEncodingSubsystem --
*
* Initialize all resources used by this subsystem on a per-process
|
| ︙ | ︙ | |||
268 269 270 271 272 273 274 |
type.nullSize = 1;
type.clientData = NULL;
defaultEncoding = Tcl_CreateEncoding(&type);
systemEncoding = Tcl_GetEncoding(NULL, type.encodingName);
type.encodingName = "utf-8";
| | | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
type.nullSize = 1;
type.clientData = NULL;
defaultEncoding = Tcl_CreateEncoding(&type);
systemEncoding = Tcl_GetEncoding(NULL, type.encodingName);
type.encodingName = "utf-8";
type.toUtfProc = UtfExtToUtfIntProc;
type.fromUtfProc = UtfIntToUtfExtProc;
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.encodingName = "unicode";
type.toUtfProc = UnicodeToUtfProc;
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
TclFinalizeEncodingSubsystem()
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
Tcl_MutexLock(&encodingMutex);
encodingsInitialized = 0;
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
while (hPtr != NULL) {
/*
* Call FreeEncoding instead of doing it directly to handle refcounts
* like escape encodings use. [Bug #524674]
* Make sure to call Tcl_FirstHashEntry repeatedly so that all
* encodings are eventually cleaned up.
| > | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
TclFinalizeEncodingSubsystem()
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
Tcl_MutexLock(&encodingMutex);
encodingsInitialized = 0;
FreeEncoding(systemEncoding);
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
while (hPtr != NULL) {
/*
* Call FreeEncoding instead of doing it directly to handle refcounts
* like escape encodings use. [Bug #524674]
* Make sure to call Tcl_FirstHashEntry repeatedly so that all
* encodings are eventually cleaned up.
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
*/
void
Tcl_FindExecutable(argv0)
CONST char *argv0; /* The value of the application's argv[0]
* (native). */
{
CONST char *name;
Tcl_DString buffer, nameString;
TclInitSubsystems(argv0);
if (argv0 == NULL) {
goto done;
}
if (tclExecutableName != NULL) {
ckfree(tclExecutableName);
tclExecutableName = NULL;
}
if ((name = TclpFindExecutable(argv0)) == NULL) {
goto done;
}
/*
* The value returned from TclpNameOfExecutable is a UTF string that
| > | > > | | | | | > | > | | | | > > > > | | | 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
*/
void
Tcl_FindExecutable(argv0)
CONST char *argv0; /* The value of the application's argv[0]
* (native). */
{
int mustCleanUtf;
CONST char *name;
Tcl_DString buffer, nameString;
TclInitSubsystems(argv0);
if (argv0 == NULL) {
goto done;
}
if (tclExecutableName != NULL) {
ckfree(tclExecutableName);
tclExecutableName = NULL;
}
if ((name = TclpFindExecutable(argv0)) == NULL) {
goto done;
}
/*
* The value returned from TclpNameOfExecutable is a UTF string that
* is possibly dirty depending on when it was initialized.
* TclFindEncodings will indicate whether we must "clean" the UTF (as
* reported by the underlying system). To assure that the UTF string
* is a properly encoded native string for this system, convert the
* UTF string to the default native encoding before the default
* encoding is initialized. Then, convert it back to UTF after the
* system encoding is loaded.
*/
Tcl_UtfToExternalDString(NULL, name, -1, &buffer);
mustCleanUtf = TclFindEncodings(argv0);
/*
* Now it is OK to convert the native string back to UTF and set
* the value of the tclExecutableName.
*/
if (mustCleanUtf) {
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&buffer), -1,
&nameString);
tclExecutableName = (char *)
ckalloc((unsigned) (Tcl_DStringLength(&nameString) + 1));
strcpy(tclExecutableName, Tcl_DStringValue(&nameString));
Tcl_DStringFree(&nameString);
} else {
tclExecutableName = (char *) ckalloc((unsigned) (strlen(name) + 1));
strcpy(tclExecutableName, name);
}
Tcl_DStringFree(&buffer);
return;
done:
(void) TclFindEncodings(argv0);
}
/*
*---------------------------------------------------------------------------
*
* LoadEncodingFile --
*
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 |
case 'E': {
encoding = LoadEscapeEncoding(name, chan);
break;
}
}
if ((encoding == NULL) && (interp != NULL)) {
Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
}
Tcl_Close(NULL, chan);
return encoding;
unknown:
if (interp != NULL) {
Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
| > > > | 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 |
case 'E': {
encoding = LoadEscapeEncoding(name, chan);
break;
}
}
if ((encoding == NULL) && (interp != NULL)) {
Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
if (ch == 'E') {
Tcl_AppendResult(interp, " or missing sub-encoding", NULL);
}
}
Tcl_Close(NULL, chan);
return encoding;
unknown:
if (interp != NULL) {
Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
|
| ︙ | ︙ | |||
1609 1610 1611 1612 1613 1614 1615 |
*/
static Tcl_Encoding
LoadEscapeEncoding(name, chan)
CONST char *name; /* Name for new encoding. */
Tcl_Channel chan; /* File containing new encoding. */
{
| | | 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 |
*/
static Tcl_Encoding
LoadEscapeEncoding(name, chan)
CONST char *name; /* Name for new encoding. */
Tcl_Channel chan; /* File containing new encoding. */
{
int i, missingSubEncoding = 0;
unsigned int size;
Tcl_DString escapeData;
char init[16], final[16];
EscapeEncodingData *dataPtr;
Tcl_EncodingType type;
init[0] = '\0';
|
| ︙ | ︙ | |||
1653 1654 1655 1656 1657 1658 1659 | strncpy(est.sequence, argv[1], sizeof(est.sequence)); est.sequence[sizeof(est.sequence) - 1] = '\0'; est.sequenceLen = strlen(est.sequence); strncpy(est.name, argv[0], sizeof(est.name)); est.name[sizeof(est.name) - 1] = '\0'; | > > > > > | | > > > | < > > > > | 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 |
strncpy(est.sequence, argv[1], sizeof(est.sequence));
est.sequence[sizeof(est.sequence) - 1] = '\0';
est.sequenceLen = strlen(est.sequence);
strncpy(est.name, argv[0], sizeof(est.name));
est.name[sizeof(est.name) - 1] = '\0';
/*
* Load the subencodings first so we're never stuck
* trying to use a half-loaded system encoding to
* open/read a *.enc file.
*/
est.encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, est.name);
if ((est.encodingPtr == NULL)
|| (est.encodingPtr->toUtfProc != TableToUtfProc)) {
missingSubEncoding = 1;
}
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
ckfree((char *) argv);
Tcl_DStringFree(&lineString);
}
if (missingSubEncoding) {
Tcl_DStringFree(&escapeData);
return NULL;
}
size = sizeof(EscapeEncodingData)
- sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData);
dataPtr = (EscapeEncodingData *) ckalloc(size);
dataPtr->initLen = strlen(init);
strcpy(dataPtr->init, init);
|
| ︙ | ︙ | |||
1755 1756 1757 1758 1759 1760 1761 |
srcLen = dstLen;
result = TCL_CONVERT_NOSPACE;
}
*srcReadPtr = srcLen;
*dstWrotePtr = srcLen;
*dstCharsPtr = srcLen;
| > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 |
srcLen = dstLen;
result = TCL_CONVERT_NOSPACE;
}
*srcReadPtr = srcLen;
*dstWrotePtr = srcLen;
*dstCharsPtr = srcLen;
memcpy((void *) dst, (void *) src, (size_t) srcLen);
return result;
}
/*
*-------------------------------------------------------------------------
*
* UtfExtToUtfIntProc --
*
* Convert from UTF-8 to UTF-8. While converting null-bytes from
* the Tcl's internal representation (0xc0, 0x80) to the official
* representation (0x00). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfIntToUtfExtProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* Not used. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr, 1);
}
/*
*-------------------------------------------------------------------------
*
* UtfExtToUtfIntProc --
*
* Convert from UTF-8 to UTF-8 while converting null-bytes from
* the official representation (0x00) to Tcl's internal
* representation (0xc0, 0x80). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr)
ClientData clientData; /* Not used. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst; /* Output buffer in which converted string
* is stored. */
int dstLen; /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr; /* Filled with the number of bytes from the
* source string that were converted. This
* may be less than the original source length
* if there was a problem converting some
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr, 0);
}
/*
*-------------------------------------------------------------------------
*
* UtfToUtfProc --
*
* Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8
* translation is not a no-op, because it will turn a stream of
* improperly formed UTF-8 into a properly formed stream.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen,
srcReadPtr, dstWrotePtr, dstCharsPtr, pureNullMode)
ClientData clientData; /* Not used. */
CONST char *src; /* Source string in UTF-8. */
int srcLen; /* Source string length in bytes. */
int flags; /* Conversion control flags. */
Tcl_EncodingState *statePtr;/* Place for conversion routine to store
* state information used during a piecewise
* conversion. Contents of statePtr are
|
| ︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 |
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
CONST char *srcStart, *srcEnd, *srcClose;
char *dstStart, *dstEnd;
int result, numChars;
Tcl_UniChar ch;
result = TCL_OK;
| > > > > | 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 |
* source characters. */
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
int pureNullMode; /* Convert embedded nulls from
* internal representation to real
* null-bytes or vice versa */
{
CONST char *srcStart, *srcEnd, *srcClose;
char *dstStart, *dstEnd;
int result, numChars;
Tcl_UniChar ch;
result = TCL_OK;
|
| ︙ | ︙ | |||
1838 1839 1840 1841 1842 1843 1844 |
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
| | > > > > > > > > > > > > > > > > > > > > > > > | | 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 |
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
if (UCHAR(*src) < 0x80 &&
!(UCHAR(*src) == 0 && pureNullMode == 0)) {
/*
* Copy 7bit chatacters, but skip null-bytes when we are
* in input mode, so that they get converted to 0xc080.
*/
*dst++ = *src++;
} else if (pureNullMode == 1 &&
UCHAR(*src) == 0xc0 &&
UCHAR(*(src+1)) == 0x80) {
/*
* Convert 0xc080 to real nulls when we are in output mode.
*/
*dst++ = 0;
src += 2;
} else if (!Tcl_UtfCharComplete(src, srcEnd - src)) {
/* Always check before using Tcl_UtfToUniChar. Not doing
* can so cause it run beyond the endof the buffer! If we
* * happen such an incomplete char its byts are made to *
* represent themselves.
*/
ch = (Tcl_UniChar) *src;
src += 1;
dst += Tcl_UniCharToUtf(ch, dst);
} else {
src += Tcl_UtfToUniChar(src, &ch);
dst += Tcl_UniCharToUtf(ch, dst);
}
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1896 1897 1898 1899 1900 1901 1902 |
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
| | > | < < | | | | > > | | | | | | 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 |
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
CONST char *srcStart, *srcEnd;
char *dstEnd, *dstStart;
int result, numChars;
Tcl_UniChar ch;
result = TCL_OK;
if ((srcLen % sizeof(Tcl_UniChar)) != 0) {
result = TCL_CONVERT_MULTIBYTE;
srcLen /= sizeof(Tcl_UniChar);
srcLen *= sizeof(Tcl_UniChar);
}
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd; numChars++) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
/*
* Special case for 1-byte utf chars for speed. Make sure we
* work with Tcl_UniChar-size data.
*/
ch = *(Tcl_UniChar *)src;
if (ch && ch < 0x80) {
*dst++ = (ch & 0xFF);
} else {
dst += Tcl_UniCharToUtf(ch, dst);
}
src += sizeof(Tcl_UniChar);
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1981 1982 1983 1984 1985 1986 1987 |
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
| | < > | < | | | | > > > > > > | > > > > > | | 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 |
int *dstWrotePtr; /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr; /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
CONST char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
int result, numChars;
Tcl_UniChar ch;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - sizeof(Tcl_UniChar);
result = TCL_OK;
for (numChars = 0; src < srcEnd; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
src += TclUtfToUniChar(src, &ch);
/*
* Need to handle this in a way that won't cause misalignment
* by casting dst to a Tcl_UniChar. [Bug 1122671]
* XXX: This hard-codes the assumed size of Tcl_UniChar as 2.
*/
#ifdef WORDS_BIGENDIAN
*dst++ = (ch >> 8);
*dst++ = (ch & 0xFF);
#else
*dst++ = (ch & 0xFF);
*dst++ = (ch >> 8);
#endif
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2209 2210 2211 2212 2213 2214 2215 | * last UTF-8 character in the source buffer hasn't been cut off. */ result = TCL_CONVERT_MULTIBYTE; break; } len = TclUtfToUniChar(src, &ch); | > > > > > > > > > > | > | 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 |
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
#if TCL_UTF_MAX > 3
/*
* This prevents a crash condition. More evaluation is required
* for full support of int Tcl_UniChar. [Bug 1004065]
*/
if (ch & 0xffff0000) {
word = 0;
} else
#endif
word = fromUnicode[(ch >> 8)][ch & 0xff];
if ((word == 0) && (ch != 0)) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
word = dataPtr->fallback;
}
|
| ︙ | ︙ | |||
2561 2562 2563 2564 2565 2566 2567 |
/*
* RFC1468 states that the text starts in ASCII, and switches to Japanese
* characters, and that the text must end in ASCII. [Patch #474358]
*/
if (flags & TCL_ENCODING_START) {
state = 0;
| | | 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 |
/*
* RFC1468 states that the text starts in ASCII, and switches to Japanese
* characters, and that the text must end in ASCII. [Patch #474358]
*/
if (flags & TCL_ENCODING_START) {
state = 0;
if ((dst + dataPtr->initLen) > dstEnd) {
*srcReadPtr = 0;
*dstWrotePtr = 0;
return TCL_CONVERT_NOSPACE;
}
memcpy((VOID *) dst, (VOID *) dataPtr->init,
(size_t) dataPtr->initLen);
dst += dataPtr->initLen;
|
| ︙ | ︙ | |||
2668 2669 2670 2671 2672 2673 2674 |
dst++;
}
src += len;
}
if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) {
unsigned int len = dataPtr->subTables[0].sequenceLen;
| > > > > > > > > > > > | > | 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 |
dst++;
}
src += len;
}
if ((result == TCL_OK) && (flags & TCL_ENCODING_END)) {
unsigned int len = dataPtr->subTables[0].sequenceLen;
/*
* [Bug 1516109].
* Certain encodings like iso2022-jp need to write
* an escape sequence after all characters have
* been converted. This logic checks that enough
* room is available in the buffer for the escape bytes.
* The TCL_ENCODING_END flag is cleared after a final
* escape sequence has been added to the buffer so
* that another call to this method does not attempt
* to append escape bytes a second time.
*/
if ((dst + dataPtr->finalLen + (state?len:0)) > dstEnd) {
result = TCL_CONVERT_NOSPACE;
} else {
if (state) {
memcpy((VOID *) dst, (VOID *) dataPtr->subTables[0].sequence,
(size_t) len);
dst += len;
}
memcpy((VOID *) dst, (VOID *) dataPtr->final,
(size_t) dataPtr->finalLen);
dst += dataPtr->finalLen;
state &= ~TCL_ENCODING_END;
}
}
*statePtr = (Tcl_EncodingState) state;
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
|
| ︙ | ︙ | |||
2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 |
{
EscapeSubTable *subTablePtr;
Encoding *encodingPtr;
subTablePtr = &dataPtr->subTables[state];
encodingPtr = subTablePtr->encodingPtr;
if (encodingPtr == NULL) {
encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name);
if ((encodingPtr == NULL)
|| (encodingPtr->toUtfProc != TableToUtfProc)) {
panic("EscapeToUtfProc: invalid sub table");
}
subTablePtr->encodingPtr = encodingPtr;
}
| > > > > > | 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 |
{
EscapeSubTable *subTablePtr;
Encoding *encodingPtr;
subTablePtr = &dataPtr->subTables[state];
encodingPtr = subTablePtr->encodingPtr;
if (encodingPtr == NULL) {
/*
* Now that escape encodings load their sub-encodings first, and
* fail to load if any sub-encodings are missing, this branch should
* never happen.
*/
encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name);
if ((encodingPtr == NULL)
|| (encodingPtr->toUtfProc != TableToUtfProc)) {
panic("EscapeToUtfProc: invalid sub table");
}
subTablePtr->encodingPtr = encodingPtr;
}
|
| ︙ | ︙ | |||
2797 2798 2799 2800 2801 2802 2803 |
p = (unsigned short *) src;
while (*p != 0x0000) {
p++;
}
return (char *) p - src;
}
| < | > | | < < > > > > | | | | | | > | | 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 |
p = (unsigned short *) src;
while (*p != 0x0000) {
p++;
}
return (char *) p - src;
}
/*
*-------------------------------------------------------------------------
*
* TclFindEncodings --
*
* Find and load the encoding file for this operating system.
* Before this is called, Tcl makes assumptions about the
* native string representation, but the true encoding is not
* assured.
*
* Results:
* Return result of TclpInitLibraryPath, which reports whether the
* path is clean (0) or dirty (1) UTF.
*
* Side effects:
* Varied, see the respective initialization routines.
*
*-------------------------------------------------------------------------
*/
static int
TclFindEncodings(argv0)
CONST char *argv0; /* Name of executable from argv[0] to main()
* in native multi-byte encoding. */
{
int mustCleanUtf = 0;
if (encodingsInitialized == 0) {
/*
* Double check inside the mutex. There may be calls
* back into this routine from some of the procedures below.
*/
TclpInitLock();
if (encodingsInitialized == 0) {
char *native;
Tcl_Obj *pathPtr;
Tcl_DString libPath, buffer;
/*
* Have to set this bit here to avoid deadlock with the
* routines below us that call into TclInitSubsystems.
*/
encodingsInitialized = 1;
native = TclpFindExecutable(argv0);
mustCleanUtf = TclpInitLibraryPath(native);
/*
* The library path was set in the TclpInitLibraryPath routine.
* The string set is a dirty UTF string. To preserve the value
* convert the UTF string back to native before setting the new
* default encoding.
*/
pathPtr = TclGetLibraryPath();
if ((pathPtr != NULL) && mustCleanUtf) {
Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr), -1,
&libPath);
}
TclpSetInitialEncodings();
/*
* Now convert the native string back to UTF.
*/
if ((pathPtr != NULL) && mustCleanUtf) {
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&libPath), -1,
&buffer);
pathPtr = Tcl_NewStringObj(Tcl_DStringValue(&buffer), -1);
TclSetLibraryPath(pathPtr);
Tcl_DStringFree(&libPath);
Tcl_DStringFree(&buffer);
}
}
TclpInitUnlock();
}
return mustCleanUtf;
}
|
Changes to generic/tclEnv.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclEnv.c,v 1.20.2.3 2006/10/31 22:25:08 das Exp $ */ #include "tclInt.h" #include "tclPort.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */ static int cacheSize = 0; /* Number of env strings in environCache. */ static char **environCache = NULL; /* Array containing all of the environment * strings that Tcl has allocated. */ #ifndef USE_PUTENV static char **ourEnviron = NULL;/* Cache of the array that we allocate. * We need to track this in case another * subsystem swaps around the environ array * like we do. */ static int environSize = 0; /* Non-zero means that the environ array was * malloced and has this many total entries * allocated to it (not all may be in use at * once). Zero means that the environment * array is in its original static state. */ #endif /* * For MacOS X */ #if defined(__APPLE__) && defined(__DYNAMIC__) #include <crt_externs.h> __private_extern__ char **environ; char **environ = NULL; #endif /* * Declarations for local procedures defined in this file: */ |
| ︙ | ︙ | |||
187 188 189 190 191 192 193 |
*/
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
if (index == -1) {
#ifndef USE_PUTENV
| > > > > > | | | | | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
*/
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
if (index == -1) {
#ifndef USE_PUTENV
/*
* We need to handle the case where the environment may be changed
* outside our control. environSize is only valid if the current
* environment is the one we allocated. [Bug 979640]
*/
if ((ourEnviron != environ) || ((length + 2) > environSize)) {
char **newEnviron;
newEnviron = (char **) ckalloc((unsigned)
((length + 5) * sizeof(char *)));
memcpy((VOID *) newEnviron, (VOID *) environ,
length*sizeof(char *));
if ((environSize != 0) && (ourEnviron != NULL)) {
ckfree((char *) ourEnviron);
}
environ = ourEnviron = newEnviron;
environSize = length + 5;
#if defined(__APPLE__) && defined(__DYNAMIC__)
{
char ***e = _NSGetEnviron();
*e = environ;
}
#endif
|
| ︙ | ︙ | |||
233 234 235 236 237 238 239 |
return;
}
Tcl_DStringFree(&envString);
oldValue = environ[index];
nameLength = length;
}
| < | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
return;
}
Tcl_DStringFree(&envString);
oldValue = environ[index];
nameLength = length;
}
/*
* Create a new entry. Build a complete UTF string that contains
* a "name=value" pattern. Then convert the string to the native
* encoding, and set the environ array value.
*/
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
void
TclUnsetEnv(name)
CONST char *name; /* Name of variable to remove (UTF-8). */
{
char *oldValue;
int length;
int index;
| | | | > > > > > > > > > > | > > > > > | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
void
TclUnsetEnv(name)
CONST char *name; /* Name of variable to remove (UTF-8). */
{
char *oldValue;
int length;
int index;
#ifdef USE_PUTENV_FOR_UNSET
Tcl_DString envString;
char *string;
#else
char **envPtr;
#endif
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
/*
* First make sure that the environment variable exists to avoid
* doing needless work and to avoid recursion on the unset.
*/
if (index == -1) {
Tcl_MutexUnlock(&envMutex);
return;
}
/*
* Remember the old value so we can free it if Tcl created the string.
*/
oldValue = environ[index];
/*
* Update the system environment. This must be done before we
* update the interpreters or we will recurse.
*/
#ifdef USE_PUTENV_FOR_UNSET
/*
* For those platforms that support putenv to unset, Linux indicates
* that no = should be included, and Windows requires it.
*/
#ifdef WIN32
string = ckalloc((unsigned int) length+2);
memcpy((VOID *) string, (VOID *) name, (size_t) length);
string[length] = '=';
string[length+1] = '\0';
#else
string = ckalloc((unsigned int) length+1);
memcpy((VOID *) string, (VOID *) name, (size_t) length);
string[length] = '\0';
#endif
Tcl_UtfToExternalDString(NULL, string, -1, &envString);
string = ckrealloc(string, (unsigned) (Tcl_DStringLength(&envString)+1));
strcpy(string, Tcl_DStringValue(&envString));
Tcl_DStringFree(&envString);
putenv(string);
/*
* Watch out for versions of putenv that copy the string (e.g. VC++).
* In this case we need to free the string immediately. Otherwise
* update the string in the cache.
*/
if (environ[index] == string) {
ReplaceString(oldValue, string);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/* This putenv() copies instead of taking ownership */
ckfree(string);
#endif
}
#else
for (envPtr = environ+index+1; ; envPtr++) {
envPtr[-1] = *envPtr;
if (*envPtr == NULL) {
break;
}
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 |
/*
* Replace or delete the old value.
*/
if (environCache[i]) {
ckfree(environCache[i]);
}
| | | | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 |
/*
* Replace or delete the old value.
*/
if (environCache[i]) {
ckfree(environCache[i]);
}
if (newStr) {
environCache[i] = newStr;
} else {
for (; i < cacheSize-1; i++) {
environCache[i] = environCache[i+1];
}
environCache[cacheSize-1] = NULL;
}
} else {
int allocatedSize = (cacheSize + 5) * sizeof(char *);
/*
* We need to grow the cache in order to hold the new string.
*/
newCache = (char **) ckalloc((unsigned) allocatedSize);
(VOID *) memset(newCache, (int) 0, (size_t) allocatedSize);
if (environCache) {
memcpy((VOID *) newCache, (VOID *) environCache,
(size_t) (cacheSize * sizeof(char*)));
ckfree((char *) environCache);
}
environCache = newCache;
environCache[cacheSize] = newStr;
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclEvent.c -- * * This file implements some general event related interfaces including * background errors, exit handlers, and the "vwait" and "update" * command procedures. * * Copyright (c) 1990-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclEvent.c -- * * This file implements some general event related interfaces including * background errors, exit handlers, and the "vwait" and "update" * command procedures. * * Copyright (c) 1990-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclEvent.c,v 1.28.2.15 2007/03/19 17:06:25 dgp Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The data structure below is used to report background errors. One |
| ︙ | ︙ | |||
96 97 98 99 100 101 102 103 |
* the standard channels. */
Tcl_Obj *tclLibraryPath; /* Path(s) to the Tcl library */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Common string for the library path for sharing across threads.
*/
| > | > > > > > > > > > > > | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
* the standard channels. */
Tcl_Obj *tclLibraryPath; /* Path(s) to the Tcl library */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Common string for the library path for sharing across threads.
* This is ckalloc'd and cleared in Tcl_Finalize.
*/
static char *tclLibraryPathStr = NULL;
#ifdef TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
ClientData clientData; /* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_((
ClientData clientData));
#endif
/*
* Prototypes for procedures referenced only in this file:
*/
static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 |
void
TclSetLibraryPath(pathPtr)
Tcl_Obj *pathPtr; /* A Tcl list object whose elements are
* the new library path. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (pathPtr != NULL) {
Tcl_IncrRefCount(pathPtr);
}
if (tsdPtr->tclLibraryPath != NULL) {
Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
}
tsdPtr->tclLibraryPath = pathPtr;
/*
* No mutex locking is needed here as up the stack we're within
* TclpInitLock().
*/
| > > > > > | > > | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
void
TclSetLibraryPath(pathPtr)
Tcl_Obj *pathPtr; /* A Tcl list object whose elements are
* the new library path. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
const char *toDupe;
int size;
if (pathPtr != NULL) {
Tcl_IncrRefCount(pathPtr);
}
if (tsdPtr->tclLibraryPath != NULL) {
Tcl_DecrRefCount(tsdPtr->tclLibraryPath);
}
tsdPtr->tclLibraryPath = pathPtr;
/*
* No mutex locking is needed here as up the stack we're within
* TclpInitLock().
*/
if (tclLibraryPathStr != NULL) {
ckfree(tclLibraryPathStr);
}
toDupe = Tcl_GetStringFromObj(pathPtr, &size);
tclLibraryPathStr = ckalloc((unsigned)size+1);
memcpy(tclLibraryPathStr, toDupe, (unsigned)size+1);
}
/*
*-------------------------------------------------------------------------
*
* TclGetLibraryPath --
*
|
| ︙ | ︙ | |||
708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 | tclExecutableName = NULL; /* * Initialize locks used by the memory allocators before anything * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ #if USE_TCLALLOC TclInitAlloc(); /* process wide mutex init */ #endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* process wide mutex init */ #endif TclpInitPlatform(); /* creates signal handler(s) */ | > | | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 |
tclExecutableName = NULL;
/*
* Initialize locks used by the memory allocators before anything
* interesting happens so we can use the allocators in the
* implementation of self-initializing locks.
*/
#if USE_TCLALLOC
TclInitAlloc(); /* process wide mutex init */
#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* process wide mutex init */
#endif
TclpInitPlatform(); /* creates signal handler(s) */
TclInitObjSubsystem(); /* register obj types, create mutexes */
TclInitIOSubsystem(); /* inits a tsd key (noop) */
TclInitEncodingSubsystem(); /* process wide encoding init */
TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */
}
TclpInitUnlock();
}
if (tsdPtr == NULL) {
/*
* First time this thread has created an interpreter.
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 |
*----------------------------------------------------------------------
*/
void
Tcl_Finalize()
{
ExitHandler *exitPtr;
| < | < < < < < < | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
*----------------------------------------------------------------------
*/
void
Tcl_Finalize()
{
ExitHandler *exitPtr;
/*
* Invoke exit handlers first.
*/
Tcl_MutexLock(&exitMutex);
inFinalize = 1;
for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
/*
* Be careful to remove the handler from the list before
* invoking its callback. This protects us against
* double-freeing if the callback should call
* Tcl_DeleteExitHandler on itself.
*/
firstExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
(*exitPtr->proc)(exitPtr->clientData);
ckfree((char *) exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
TclpInitLock();
if (subsystemsInitialized != 0) {
subsystemsInitialized = 0;
/*
* Ensure the thread-specific data is initialised as it is
* used in Tcl_FinalizeThread()
*/
(void) TCL_TSD_INIT(&dataKey);
/*
* Clean up after the current thread now, after exit handlers.
* In particular, the testexithandler command sets up something
* that writes to standard output, which gets closed.
* Note that there is no thread-local storage after this call.
*/
Tcl_FinalizeThread();
/*
* Now finalize the Tcl execution environment. Note that this
* must be done after the exit handlers, because there are
* order dependencies.
*/
TclFinalizeCompilation();
TclFinalizeExecution();
TclFinalizeEnvironment();
/*
* Finalizing the filesystem must come after anything which
* might conceivably interact with the 'Tcl_FS' API.
*/
TclFinalizeFilesystem();
/*
* Undo all the Tcl_ObjType registrations, and reset the master list
* of free Tcl_Obj's. After this returns, no more Tcl_Obj's should
* be allocated or freed.
*
* Note in particular that TclFinalizeObjects() must follow
* TclFinalizeFilesystem() because TclFinalizeFilesystem free's
* the Tcl_Obj that holds the path of the current working directory.
*/
TclFinalizeObjects();
/*
* We must be sure the encoding finalization doesn't need
* to examine the filesystem in any way. Since it only
* needs to clean up internal data structures, this is
* fine.
*/
TclFinalizeEncodingSubsystem();
if (tclExecutableName != NULL) {
ckfree(tclExecutableName);
tclExecutableName = NULL;
}
if (tclNativeExecutableName != NULL) {
ckfree(tclNativeExecutableName);
tclNativeExecutableName = NULL;
}
if (tclDefaultEncodingDir != NULL) {
ckfree(tclDefaultEncodingDir);
tclDefaultEncodingDir = NULL;
}
if (tclLibraryPathStr != NULL) {
ckfree(tclLibraryPathStr);
tclLibraryPathStr = NULL;
}
Tcl_SetPanicProc(NULL);
/*
* There have been several bugs in the past that cause
* exit handlers to be established during Tcl_Finalize
* processing. Such exit handlers leave malloc'ed memory,
* and Tcl_FinalizeThreadAlloc or Tcl_FinalizeMemorySubsystem
* will result in a corrupted heap. The result can be a
* mysterious crash on process exit. Check here that
* nobody's done this.
*/
#ifdef TCL_MEM_DEBUG
if ( firstExitPtr != NULL ) {
Tcl_Panic( "exit handlers were created during Tcl_Finalize" );
}
#endif
TclFinalizePreserve();
/*
* Free synchronization objects. There really should only be one
* thread alive at this moment.
*/
TclFinalizeSynchronization();
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG) && !defined(PURIFY)
TclFinalizeThreadAlloc();
#endif
/*
* We defer unloading of packages until very late
* to avoid memory access issues. Both exit callbacks and
* synchronization variables may be stored in packages.
*
* Note that TclFinalizeLoad unloads packages in the reverse
* of the order they were loaded in (i.e. last to be loaded
* is the first to be unloaded). This can be important for
* correct unloading when dependencies exist.
*
* Once load has been finalized, we will have deleted any
* temporary copies of shared libraries and can therefore
* reset the filesystem to its original state.
*/
TclFinalizeLoad();
TclResetFilesystem();
/*
* At this point, there should no longer be any ckalloc'ed memory.
*/
TclFinalizeMemorySubsystem();
inFinalize = 0;
}
TclFinalizeLock();
}
/*
*----------------------------------------------------------------------
*
* Tcl_FinalizeThread --
*
|
| ︙ | ︙ | |||
893 894 895 896 897 898 899 |
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeThread()
{
ExitHandler *exitPtr;
| | < > | 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 |
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeThread()
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr;
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
/*
* Clean up the library path now, before we invalidate thread-local
* storage or calling thread exit handlers.
*/
|
| ︙ | ︙ | |||
926 927 928 929 930 931 932 |
ckfree((char *) exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
TclFinalizeAsync();
}
| | | | | | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 |
ckfree((char *) exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
TclFinalizeAsync();
}
/*
* Blow away all thread local storage blocks.
*
* Note that Tcl API allows creation of threads which do not use any
* Tcl interp or other Tcl subsytems. Those threads might, however,
* use thread local storage, so we must unconditionally finalize it.
*
* Fix [Bug #571002]
*/
TclFinalizeThreadData();
}
/*
*----------------------------------------------------------------------
*
* TclInExit --
*
|
| ︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 |
* Must clear the interpreter's result because event handlers could
* have executed commands.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 |
* Must clear the interpreter's result because event handlers could
* have executed commands.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
#ifdef TCL_THREADS
/*
*-----------------------------------------------------------------------------
*
* NewThreadProc --
*
* Bootstrap function of a new Tcl thread.
*
* Results:
* None.
*
* Side Effects:
* Initializes Tcl notifier for the current thread.
*
*-----------------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
NewThreadProc(ClientData clientData)
{
ThreadClientData *cdPtr;
ClientData threadClientData;
Tcl_ThreadCreateProc *threadProc;
cdPtr = (ThreadClientData*)clientData;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
ckfree((char*)clientData); /* Allocated in Tcl_CreateThread() */
(*threadProc)(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_CreateThread --
*
* This procedure creates a new thread. This actually belongs
* to the tclThread.c file but since we use some private
* data structures local to this file, it is placed here.
*
* Results:
* TCL_OK if the thread could be created. The thread ID is
* returned in a parameter.
*
* Side effects:
* A new thread is created.
*
*----------------------------------------------------------------------
*/
int
Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags)
Tcl_ThreadId *idPtr; /* Return, the ID of the thread */
Tcl_ThreadCreateProc proc; /* Main() function of the thread */
ClientData clientData; /* The one argument to Main() */
int stackSize; /* Size of stack for the new thread */
int flags; /* Flags controlling behaviour of
* the new thread */
{
#ifdef TCL_THREADS
ThreadClientData *cdPtr;
cdPtr = (ThreadClientData*)ckalloc(sizeof(ThreadClientData));
cdPtr->proc = proc;
cdPtr->clientData = clientData;
return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr,
stackSize, flags);
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
}
|
Changes to generic/tclExecute.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclExecute.c -- * * This file contains procedures that execute byte-compiled Tcl * commands. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclExecute.c -- * * This file contains procedures that execute byte-compiled Tcl * commands. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclExecute.c,v 1.94.2.21 2007/03/13 16:26:32 dgp Exp $ */ #include "tclInt.h" #include "tclCompile.h" #ifndef TCL_NO_MATH # include "tclMath.h" |
| ︙ | ︙ | |||
254 255 256 257 258 259 260 | #else /* !TCL_COMPILE_DEBUG */ # define TRACE(a) # define TRACE_APPEND(a) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ | < < < < < < < < < < < < | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | #else /* !TCL_COMPILE_DEBUG */ # define TRACE(a) # define TRACE_APPEND(a) # define TRACE_WITH_OBJ(a, objPtr) # define O2S(objPtr) #endif /* TCL_COMPILE_DEBUG */ /* * Macro to read a string containing either a wide or an int and * decide which it is while decoding it at the same time. This * enforces the policy that integer constants between LONG_MIN and * LONG_MAX (inclusive) are represented by normal longs, and integer * constants outside that range are represented by wide ints. * |
| ︙ | ︙ | |||
293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
&(wideVar)); \
if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
&& (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
(objPtr)->typePtr = &tclIntType; \
(objPtr)->internalRep.longValue = (longVar) \
= Tcl_WideAsLong(wideVar); \
}
#define IS_INTEGER_TYPE(typePtr) \
((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
/*
* Extract a double value from a general numeric object.
*/
#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
if ((typePtr) == &tclIntType) { \
(doubleVar) = (double) (objPtr)->internalRep.longValue; \
} else if ((typePtr) == &tclWideIntType) { \
(doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\
} else { \
(doubleVar) = (objPtr)->internalRep.doubleValue; \
}
| > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
&(wideVar)); \
if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
&& (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
(objPtr)->typePtr = &tclIntType; \
(objPtr)->internalRep.longValue = (longVar) \
= Tcl_WideAsLong(wideVar); \
}
/*
* Combined with REQUIRE_WIDE_OR_INT, this gets a long value from
* an obj.
*/
#define FORCE_LONG(objPtr, longVar, wideVar) \
if ((objPtr)->typePtr == &tclWideIntType) { \
(longVar) = Tcl_WideAsLong(wideVar); \
}
#define IS_INTEGER_TYPE(typePtr) \
((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
#define IS_NUMERIC_TYPE(typePtr) \
(IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)
#define W0 Tcl_LongAsWide(0)
/*
* For tracing that uses wide values.
*/
#define LLD "%" TCL_LL_MODIFIER "d"
#ifndef TCL_WIDE_INT_IS_LONG
/*
* Extract a double value from a general numeric object.
*/
#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
if ((typePtr) == &tclIntType) { \
(doubleVar) = (double) (objPtr)->internalRep.longValue; \
} else if ((typePtr) == &tclWideIntType) { \
(doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\
} else { \
(doubleVar) = (objPtr)->internalRep.doubleValue; \
}
#else /* TCL_WIDE_INT_IS_LONG */
#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \
(doubleVar) = (double) (objPtr)->internalRep.longValue; \
} else { \
(doubleVar) = (objPtr)->internalRep.doubleValue; \
}
#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Declarations for local procedures to this file:
*/
static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
ByteCode *codePtr));
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 | ExecEnv *eePtr, ClientData clientData)); static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp, ExecEnv *eePtr, ClientData clientData)); static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp, ExecEnv *eePtr, ClientData clientData)); static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, ExecEnv *eePtr, ClientData clientData)); | < < | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 |
ExecEnv *eePtr, ClientData clientData));
static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
#ifdef TCL_COMPILE_STATS
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 |
#endif
{"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
{"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
{"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
{"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
{"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
| < < < < | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
#endif
{"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
{"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
{"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
{"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
{"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
{"wide", 1, {TCL_EITHER}, ExprWideFunc, 0},
{0},
};
/*
*----------------------------------------------------------------------
*
* InitByteCodeExecution --
|
| ︙ | ︙ | |||
771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 |
} else {
(*tclByteCodeType.freeIntRepProc)(objPtr);
objPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
}
if (objPtr->typePtr != &tclByteCodeType) {
TclInitCompileEnv(interp, &compEnv, string, length);
result = TclCompileExpr(interp, string, length, &compEnv);
/*
* Free the compilation environment's literal table bucket array if
* it was dynamically allocated.
*/
| > > > > > | 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 |
} else {
(*tclByteCodeType.freeIntRepProc)(objPtr);
objPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
}
if (objPtr->typePtr != &tclByteCodeType) {
#ifndef TCL_TIP280
TclInitCompileEnv(interp, &compEnv, string, length);
#else
/* TIP #280 : No invoker (yet) - Expression compilation */
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
#endif
result = TclCompileExpr(interp, string, length, &compEnv);
/*
* Free the compilation environment's literal table bucket array if
* it was dynamically allocated.
*/
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 |
* Side effects:
* Almost certainly, depending on the ByteCode's instructions.
*
*----------------------------------------------------------------------
*/
int
TclCompEvalObj(interp, objPtr)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
{
register Interp *iPtr = (Interp *) interp;
register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
* at all were executed. */
char *script;
int numSrcBytes;
int result;
Namespace *namespacePtr;
/*
* Check that the interpreter is ready to execute scripts
*/
if (TclInterpReady(interp) == TCL_ERROR) {
return TCL_ERROR;
}
if (iPtr->varFramePtr != NULL) {
namespacePtr = iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = iPtr->globalNsPtr;
}
/*
* If the object is not already of tclByteCodeType, compile it (and
* reset the compilation flags in the interpreter; this should be
* done after any compilation).
* Otherwise, check that it is "fresh" enough.
*/
if (objPtr->typePtr != &tclByteCodeType) {
recompileObj:
iPtr->errorLine = 1;
result = tclByteCodeType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
return result;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > < | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 |
* Side effects:
* Almost certainly, depending on the ByteCode's instructions.
*
*----------------------------------------------------------------------
*/
int
#ifndef TCL_TIP280
TclCompEvalObj(interp, objPtr)
#else
TclCompEvalObj(interp, objPtr, invoker, word)
#endif
Tcl_Interp *interp;
Tcl_Obj *objPtr;
#ifdef TCL_TIP280
CONST CmdFrame* invoker; /* Frame of the command doing the eval */
int word; /* Index of the word which is in objPtr */
#endif
{
register Interp *iPtr = (Interp *) interp;
register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
* at all were executed. */
char *script;
int numSrcBytes;
int result;
Namespace *namespacePtr;
/*
* Check that the interpreter is ready to execute scripts
*/
iPtr->numLevels++;
if (TclInterpReady(interp) == TCL_ERROR) {
iPtr->numLevels--;
return TCL_ERROR;
}
if (iPtr->varFramePtr != NULL) {
namespacePtr = iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = iPtr->globalNsPtr;
}
/*
* If the object is not already of tclByteCodeType, compile it (and
* reset the compilation flags in the interpreter; this should be
* done after any compilation).
* Otherwise, check that it is "fresh" enough.
*/
if (objPtr->typePtr != &tclByteCodeType) {
recompileObj:
iPtr->errorLine = 1;
#ifdef TCL_TIP280
/* TIP #280. Remember the invoker for a moment in the interpreter
* structures so that the byte code compiler can pick it up when
* initializing the compilation environment, i.e. the extended
* location information.
*/
iPtr->invokeCmdFramePtr = invoker;
iPtr->invokeWord = word;
#endif
result = tclByteCodeType.setFromAnyProc(interp, objPtr);
#ifdef TCL_TIP280
iPtr->invokeCmdFramePtr = NULL;
#endif
if (result != TCL_OK) {
iPtr->numLevels--;
return result;
}
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
} else {
/*
* Make sure the Bytecode hasn't been invalidated by, e.g., someone
* redefining a command with a compile procedure (this might make the
* compiled code wrong).
* The object needs to be recompiled if it was compiled in/for a
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 |
if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
/*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
*/
codePtr->refCount++;
| < < > > | 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 |
if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
/*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
*/
codePtr->refCount++;
result = TclExecuteByteCode(interp, codePtr);
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
} else {
result = TCL_OK;
}
iPtr->numLevels--;
/*
* If no commands at all were executed, check for asynchronous
* handlers so that they at least get one change to execute.
* This is needed to handle event loops written in Tcl with
* empty bodies.
*/
|
| ︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 |
* process break, continue, and errors. */
int result = TCL_OK; /* Return code returned after execution. */
int storeFlags;
Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
char *bytes;
int length;
long i = 0; /* Init. avoids compiler warning. */
| < < > > > > > > > > > > > > > > > > > > > > > > > > > > | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
* process break, continue, and errors. */
int result = TCL_OK; /* Return code returned after execution. */
int storeFlags;
Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
char *bytes;
int length;
long i = 0; /* Init. avoids compiler warning. */
Tcl_WideInt w;
register int cleanup;
Tcl_Obj *objResultPtr;
char *part1, *part2;
Var *varPtr, *arrayPtr;
CallFrame *varFramePtr = iPtr->varFramePtr;
#ifdef TCL_TIP280
/* TIP #280 : Structures for tracking lines */
CmdFrame bcFrame;
#endif
#ifdef TCL_COMPILE_DEBUG
int traceInstructions = (tclTraceExec == 3);
char cmdNameBuf[21];
#endif
/*
* This procedure uses a stack to hold information about catch commands.
* This information is the current operand stack top when starting to
* execute the code for each catch command. It starts out with stack-
* allocated space but uses dynamically-allocated storage if needed.
*/
#define STATIC_CATCH_STACK_SIZE 4
int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
int *catchStackPtr = catchStackStorage;
int catchTop = -1;
#ifdef TCL_TIP280
/* TIP #280 : Initialize the frame. Do not push it yet. */
bcFrame.type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
? TCL_LOCATION_PREBC
: TCL_LOCATION_BC);
bcFrame.level = (iPtr->cmdFramePtr == NULL ?
1 :
iPtr->cmdFramePtr->level + 1);
bcFrame.framePtr = iPtr->framePtr;
bcFrame.nextPtr = iPtr->cmdFramePtr;
bcFrame.nline = 0;
bcFrame.line = NULL;
bcFrame.data.tebc.codePtr = codePtr;
bcFrame.data.tebc.pc = NULL;
bcFrame.cmd.str.cmd = NULL;
bcFrame.cmd.str.len = 0;
#endif
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
fflush(stdout);
}
|
| ︙ | ︙ | |||
1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 |
NEXT_INST_F(5, 0, 1);
case INST_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
{
int totalLen = 0;
/*
* Concatenate strings (with no separators) from the top
* opnd items on the stack starting with the deepest item.
* First, determine how many characters are needed.
*/
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
| > > > > > > > > > > > > > > > > | 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 |
NEXT_INST_F(5, 0, 1);
case INST_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
{
int totalLen = 0;
/*
* Peephole optimisation for appending an empty string.
* This enables replacing 'K $x [set x{}]' by '$x[set x{}]'
* for fastest execution. Avoid doing the optimisation for wide
* ints - a case where equal strings may refer to different values
* (see [Bug 1251791]).
*/
if ((opnd == 2) && (stackPtr[stackTop-1]->typePtr != &tclWideIntType)) {
Tcl_GetStringFromObj(stackPtr[stackTop], &length);
if (length == 0) {
/* Just drop the top item from the stack */
NEXT_INST_F(2, 1, 0);
}
}
/*
* Concatenate strings (with no separators) from the top
* opnd items on the stack starting with the deepest item.
* First, determine how many characters are needed.
*/
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
|
| ︙ | ︙ | |||
1419 1420 1421 1422 1423 1424 1425 | * trace procedures. */ preservedStackRefCountPtr = (char **) (stackPtr-1); ++*preservedStackRefCountPtr; /* | | > > > < > > > > > > > > | 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 | * trace procedures. */ preservedStackRefCountPtr = (char **) (stackPtr-1); ++*preservedStackRefCountPtr; /* * Finally, let TclEvalObjvInternal handle the command. * * TIP #280 : Record the last piece of info needed by * 'TclGetSrcInfoForPc', and push the frame. */ #ifdef TCL_TIP280 bcFrame.data.tebc.pc = pc; iPtr->cmdFramePtr = &bcFrame; #endif DECACHE_STACK_INFO(); Tcl_ResetResult(interp); result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); CACHE_STACK_INFO(); #ifdef TCL_TIP280 iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; #endif /* * If the old stack is going to be released, it is * safe to do so now, since no references to objv are * going to be used from now on. */ |
| ︙ | ︙ | |||
1448 1449 1450 1451 1452 1453 1454 |
* with the next instruction.
*/
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
objResultPtr = Tcl_GetObjResult(interp);
| > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < > | 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 |
* with the next instruction.
*/
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
objResultPtr = Tcl_GetObjResult(interp);
/*
* Reset the interp's result to avoid possible duplications
* of large objects [Bug 781585]. We do not call
* Tcl_ResetResult() to avoid any side effects caused by
* the resetting of errorInfo and errorCode [Bug 804681],
* which are not needed here. We chose instead to manipulate
* the interp's object result directly.
*
* Note that the result object is now in objResultPtr, it
* keeps the refCount it had in its role of iPtr->objResultPtr.
*/
{
Tcl_Obj *newObjResultPtr;
TclNewObj(newObjResultPtr);
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_V(pcAdjustment, opnd, -1);
} else {
cleanup = opnd;
goto processExceptionReturn;
}
}
case INST_EVAL_STK:
/*
* Note to maintainers: it is important that INST_EVAL_STK
* pop its argument from the stack before jumping to
* checkForCatch! DO NOT OPTIMISE!
*/
objPtr = stackPtr[stackTop];
DECACHE_STACK_INFO();
#ifndef TCL_TIP280
result = TclCompEvalObj(interp, objPtr);
#else
/* TIP #280: The invoking context is left NULL for a dynamically
* constructed command. We cannot match its lines to the outer
* context.
*/
result = TclCompEvalObj(interp, objPtr, NULL,0);
#endif
CACHE_STACK_INFO();
if (result == TCL_OK) {
/*
* Normal return; push the eval's object result.
*/
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
Tcl_GetObjResult(interp));
/*
* Reset the interp's result to avoid possible duplications
* of large objects [Bug 781585]. We do not call
* Tcl_ResetResult() to avoid any side effects caused by
* the resetting of errorInfo and errorCode [Bug 804681],
* which are not needed here. We chose instead to manipulate
* the interp's object result directly.
*
* Note that the result object is now in objResultPtr, it
* keeps the refCount it had in its role of iPtr->objResultPtr.
*/
{
Tcl_Obj *newObjResultPtr;
TclNewObj(newObjResultPtr);
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_F(1, 1, -1);
} else {
cleanup = 1;
goto processExceptionReturn;
}
case INST_EXPR_STK:
objPtr = stackPtr[stackTop];
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
result = Tcl_ExprObj(interp, objPtr, &valuePtr);
CACHE_STACK_INFO();
if (result != TCL_OK) {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
O2S(objPtr)), Tcl_GetObjResult(interp));
goto checkForCatch;
}
|
| ︙ | ︙ | |||
1905 1906 1907 1908 1909 1910 1911 |
case INST_INCR_ARRAY_STK:
case INST_INCR_SCALAR_STK:
case INST_INCR_STK:
opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
| < | < > > | 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 |
case INST_INCR_ARRAY_STK:
case INST_INCR_SCALAR_STK:
case INST_INCR_STK:
opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetLongFromWide(i,valuePtr);
} else {
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
DECACHE_STACK_INFO();
Tcl_AddErrorInfo(interp, "\n (reading increment)");
CACHE_STACK_INFO();
goto checkForCatch;
}
FORCE_LONG(valuePtr, i, w);
}
stackTop--;
TclDecrRefCount(valuePtr);
switch (*pc) {
|
| ︙ | ︙ | |||
1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
}
part1 = TclGetString(objPtr);
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
if (varPtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = ((part2 == NULL)? 1 : 2);
goto doIncrVar;
| > > | 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
}
part1 = TclGetString(objPtr);
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
if (varPtr == NULL) {
DECACHE_STACK_INFO();
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = ((part2 == NULL)? 1 : 2);
goto doIncrVar;
|
| ︙ | ︙ | |||
2095 2096 2097 2098 2099 2100 2101 |
int b;
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclIntType) {
b = (valuePtr->internalRep.longValue != 0);
} else if (valuePtr->typePtr == &tclDoubleType) {
b = (valuePtr->internalRep.doubleValue != 0.0);
| < | < > | 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 |
int b;
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclIntType) {
b = (valuePtr->internalRep.longValue != 0);
} else if (valuePtr->typePtr == &tclDoubleType) {
b = (valuePtr->internalRep.doubleValue != 0.0);
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
b = (w != W0);
} else {
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
goto checkForCatch;
}
}
|
| ︙ | ︙ | |||
2150 2151 2152 2153 2154 2155 2156 |
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];;
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
i1 = (valuePtr->internalRep.longValue != 0);
| < | < > < < < < < < > > < | < > < < < < < < > > | 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 |
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];;
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
i1 = (valuePtr->internalRep.longValue != 0);
} else if (t1Ptr == &tclWideIntType) {
TclGetWide(w,valuePtr);
i1 = (w != W0);
} else if (t1Ptr == &tclDoubleType) {
i1 = (valuePtr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
if (valuePtr->typePtr == &tclIntType) {
i1 = (i != 0);
} else {
i1 = (w != W0);
}
} else {
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
valuePtr, &i1);
i1 = (i1 != 0);
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(t1Ptr? t1Ptr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
i2 = (value2Ptr->internalRep.longValue != 0);
} else if (t2Ptr == &tclWideIntType) {
TclGetWide(w,value2Ptr);
i2 = (w != W0);
} else if (t2Ptr == &tclDoubleType) {
i2 = (value2Ptr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, value2Ptr, i, w);
if (value2Ptr->typePtr == &tclIntType) {
i2 = (i != 0);
} else {
i2 = (w != W0);
}
} else {
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2);
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
(t2Ptr? t2Ptr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
|
| ︙ | ︙ | |||
2699 2700 2701 2702 2703 2704 2705 2706 2707 |
double d1 = 0.0; /* Init. avoids compiler warning. */
double d2 = 0.0; /* Init. avoids compiler warning. */
long iResult = 0; /* Init. avoids compiler warning. */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
if (valuePtr == value2Ptr) {
/*
| > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > | | | | > | | | > > | | > | < | 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 |
double d1 = 0.0; /* Init. avoids compiler warning. */
double d2 = 0.0; /* Init. avoids compiler warning. */
long iResult = 0; /* Init. avoids compiler warning. */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
/*
* Be careful in the equal-object case; 'NaN' isn't supposed
* to be equal to even itself. [Bug 761471]
*/
t1Ptr = valuePtr->typePtr;
if (valuePtr == value2Ptr) {
/*
* If we are numeric already, we can proceed to the main
* equality check right now. Otherwise, we need to try to
* coerce to a numeric type so we can see if we've got a
* NaN but haven't parsed it as numeric.
*/
if (!IS_NUMERIC_TYPE(t1Ptr)) {
if (t1Ptr == &tclListType) {
int length;
/*
* Only a list of length 1 can be NaN or such
* things.
*/
(void) Tcl_ListObjLength(NULL, valuePtr, &length);
if (length == 1) {
goto mustConvertForNaNCheck;
}
} else {
/*
* Too bad, we'll have to compute the string and
* try the conversion
*/
mustConvertForNaNCheck:
s1 = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s1, length)) {
GET_WIDE_OR_INT(iResult, valuePtr, i, w);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
}
t1Ptr = valuePtr->typePtr;
}
}
switch (*pc) {
case INST_EQ:
case INST_LE:
case INST_GE:
iResult = !((t1Ptr == &tclDoubleType)
&& IS_NAN(valuePtr->internalRep.doubleValue));
break;
case INST_LT:
case INST_GT:
iResult = 0;
break;
case INST_NEQ:
iResult = ((t1Ptr == &tclDoubleType)
&& IS_NAN(valuePtr->internalRep.doubleValue));
break;
}
goto foundResult;
}
t2Ptr = value2Ptr->typePtr;
/*
* We only want to coerce numeric validation if neither type
* is NULL. A NULL type means the arg is essentially an empty
* object ("", {} or [list]).
*/
|
| ︙ | ︙ | |||
2821 2822 2823 2824 2825 2826 2827 | case INST_LE: iResult = d1 <= d2; break; case INST_GE: iResult = d1 >= d2; break; } | < | | | | | 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 |
case INST_LE:
iResult = d1 <= d2;
break;
case INST_GE:
iResult = d1 >= d2;
break;
}
} else if ((t1Ptr == &tclWideIntType)
|| (t2Ptr == &tclWideIntType)) {
Tcl_WideInt w2;
/*
* Compare as wide ints (neither are doubles)
*/
if (t1Ptr == &tclIntType) {
w = Tcl_LongAsWide(valuePtr->internalRep.longValue);
TclGetWide(w2,value2Ptr);
} else if (t2Ptr == &tclIntType) {
TclGetWide(w,valuePtr);
w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
} else {
TclGetWide(w,valuePtr);
TclGetWide(w2,value2Ptr);
}
switch (*pc) {
case INST_EQ:
iResult = w == w2;
break;
case INST_NEQ:
iResult = w != w2;
|
| ︙ | ︙ | |||
2858 2859 2860 2861 2862 2863 2864 | case INST_LE: iResult = w <= w2; break; case INST_GE: iResult = w >= w2; break; } | < | 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 |
case INST_LE:
iResult = w <= w2;
break;
case INST_GE:
iResult = w >= w2;
break;
}
} else {
/*
* Compare as ints.
*/
i = valuePtr->internalRep.longValue;
i2 = value2Ptr->internalRep.longValue;
switch (*pc) {
|
| ︙ | ︙ | |||
2925 2926 2927 2928 2929 2930 2931 |
{
/*
* Only integers are allowed. We compute value op value2.
*/
long i2 = 0, rem, negative;
long iResult = 0; /* Init. avoids compiler warning. */
| < < < | < > > < | < > > < < < < < < | | | < < | 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 |
{
/*
* Only integers are allowed. We compute value op value2.
*/
long i2 = 0, rem, negative;
long iResult = 0; /* Init. avoids compiler warning. */
Tcl_WideInt w2, wResult = W0;
int doWide = 0;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
} else { /* try to convert to int */
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
O2S(valuePtr), O2S(value2Ptr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
if (value2Ptr->typePtr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
} else if (value2Ptr->typePtr == &tclWideIntType) {
TclGetWide(w2,value2Ptr);
} else {
REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(valuePtr), O2S(value2Ptr),
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
switch (*pc) {
case INST_MOD:
/*
* This code is tricky: C doesn't guarantee much about
* the quotient or remainder, but Tcl does. The
* remainder always has the same sign as the divisor and
* a smaller absolute value.
*/
if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
if (valuePtr->typePtr == &tclIntType) {
TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
} else {
TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
}
goto divideByZero;
}
if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
if (valuePtr->typePtr == &tclIntType) {
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
} else {
TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
}
goto divideByZero;
}
negative = 0;
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
Tcl_WideInt wRemainder;
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
|
| ︙ | ︙ | |||
3027 3028 3029 3030 3031 3032 3033 |
if (negative) {
wRemainder = -wRemainder;
}
wResult = wRemainder;
doWide = 1;
break;
}
| < < > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > | > < | | > > > > > > > > > > > > > > > > > > > < | | > > > > > > > > > > > > > > > > > > > < < < < < < < | < < < < | < < < < < < | < | 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 |
if (negative) {
wRemainder = -wRemainder;
}
wResult = wRemainder;
doWide = 1;
break;
}
if (i2 < 0) {
i2 = -i2;
i = -i;
negative = 1;
}
rem = i % i2;
if (rem < 0) {
rem += i2;
}
if (negative) {
rem = -rem;
}
iResult = rem;
break;
case INST_LSHIFT:
/*
* Shifts are never usefully 64-bits wide!
*/
FORCE_LONG(value2Ptr, i2, w2);
if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
wResult = w;
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
wResult = Tcl_LongAsWide(0);
} else if (i2 > 60) {
wResult = w << 30;
wResult <<= 30;
wResult <<= i2-60;
} else if (i2 > 30) {
wResult = w << 30;
wResult <<= i2-30;
} else {
wResult = w << i2;
}
doWide = 1;
break;
}
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
iResult = 0;
} else if (i2 > 60) {
iResult = i << 30;
iResult <<= 30;
iResult <<= i2-60;
} else if (i2 > 30) {
iResult = i << 30;
iResult <<= i2-30;
} else {
iResult = i << i2;
}
break;
case INST_RSHIFT:
/*
* The following code is a bit tricky: it ensures that
* right shifts propagate the sign bit even on machines
* where ">>" won't do it by default.
*/
/*
* Shifts are never usefully 64-bits wide!
*/
FORCE_LONG(value2Ptr, i2, w2);
if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
if (w < 0) {
wResult = ~w;
} else {
wResult = w;
}
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
wResult = Tcl_LongAsWide(0);
} else if (i2 > 60) {
wResult >>= 30;
wResult >>= 30;
wResult >>= i2-60;
} else if (i2 > 30) {
wResult >>= 30;
wResult >>= i2-30;
} else {
wResult >>= i2;
}
if (w < 0) {
wResult = ~wResult;
}
doWide = 1;
break;
}
if (i < 0) {
iResult = ~i;
} else {
iResult = i;
}
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
iResult = 0;
} else if (i2 > 60) {
iResult >>= 30;
iResult >>= 30;
iResult >>= i2-60;
} else if (i2 > 30) {
iResult >>= 30;
iResult >>= i2-30;
} else {
iResult >>= i2;
}
if (i < 0) {
iResult = ~iResult;
}
break;
case INST_BITOR:
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
wResult = w | w2;
doWide = 1;
break;
}
iResult = i | i2;
break;
case INST_BITXOR:
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
wResult = w ^ w2;
doWide = 1;
break;
}
iResult = i ^ i2;
break;
case INST_BITAND:
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
wResult = w & w2;
doWide = 1;
break;
}
iResult = i & i2;
break;
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
if (doWide) {
objResultPtr = Tcl_NewWideIntObj(wResult);
TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
} else {
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
}
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
if (doWide) {
TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
Tcl_SetWideIntObj(valuePtr, wResult);
} else {
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
}
NEXT_INST_F(1, 1, 0);
}
}
case INST_ADD:
case INST_SUB:
case INST_MULT:
case INST_DIV:
{
/*
* Operands must be numeric and ints get converted to floats
* if necessary. We compute value op value2.
*/
Tcl_ObjType *t1Ptr, *t2Ptr;
long i2 = 0, quot, rem; /* Init. avoids compiler warning. */
double d1, d2;
long iResult = 0; /* Init. avoids compiler warning. */
double dResult = 0.0; /* Init. avoids compiler warning. */
int doDouble = 0; /* 1 if doing floating arithmetic */
Tcl_WideInt w2, wquot, wrem;
Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
int doWide = 0; /* 1 if doing wide arithmetic. */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if (t1Ptr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if (t1Ptr == &tclWideIntType) {
TclGetWide(w,valuePtr);
} else if ((t1Ptr == &tclDoubleType)
&& (valuePtr->bytes == NULL)) {
/*
* We can only use the internal rep directly if there is
* no string rep. Otherwise the string rep might actually
* look like an integer, which is preferred.
*/
|
| ︙ | ︙ | |||
3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 |
valuePtr, &d1);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
s, O2S(valuePtr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
t1Ptr = valuePtr->typePtr;
}
if (t2Ptr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
| > > < | < | 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 |
valuePtr, &d1);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
s, O2S(valuePtr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
t1Ptr = valuePtr->typePtr;
}
if (t2Ptr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
} else if (t2Ptr == &tclWideIntType) {
TclGetWide(w2,value2Ptr);
} else if ((t2Ptr == &tclDoubleType)
&& (value2Ptr->bytes == NULL)) {
/*
* We can only use the internal rep directly if there is
* no string rep. Otherwise the string rep might actually
* look like an integer, which is preferred.
*/
|
| ︙ | ︙ | |||
3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 |
value2Ptr, &d2);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(value2Ptr), s,
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, value2Ptr);
goto checkForCatch;
}
t2Ptr = value2Ptr->typePtr;
}
if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
/*
* Do double arithmetic.
*/
doDouble = 1;
if (t1Ptr == &tclIntType) {
d1 = i; /* promote value 1 to double */
} else if (t2Ptr == &tclIntType) {
d2 = i2; /* promote value 2 to double */
| > > < < | 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 |
value2Ptr, &d2);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(value2Ptr), s,
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto checkForCatch;
}
t2Ptr = value2Ptr->typePtr;
}
if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
/*
* Do double arithmetic.
*/
doDouble = 1;
if (t1Ptr == &tclIntType) {
d1 = i; /* promote value 1 to double */
} else if (t2Ptr == &tclIntType) {
d2 = i2; /* promote value 2 to double */
} else if (t1Ptr == &tclWideIntType) {
d1 = Tcl_WideAsDouble(w);
} else if (t2Ptr == &tclWideIntType) {
d2 = Tcl_WideAsDouble(w2);
}
switch (*pc) {
case INST_ADD:
dResult = d1 + d2;
break;
case INST_SUB:
dResult = d1 - d2;
|
| ︙ | ︙ | |||
3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 |
/*
* Check now for IEEE floating-point error.
*/
if (IS_NAN(dResult) || IS_INF(dResult)) {
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
O2S(valuePtr), O2S(value2Ptr)));
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto checkForCatch;
}
| > > < | 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 |
/*
* Check now for IEEE floating-point error.
*/
if (IS_NAN(dResult) || IS_INF(dResult)) {
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
O2S(valuePtr), O2S(value2Ptr)));
DECACHE_STACK_INFO();
TclExprFloatError(interp, dResult);
CACHE_STACK_INFO();
result = TCL_ERROR;
goto checkForCatch;
}
} else if ((t1Ptr == &tclWideIntType)
|| (t2Ptr == &tclWideIntType)) {
/*
* Do wide integer arithmetic.
*/
doWide = 1;
if (t1Ptr == &tclIntType) {
|
| ︙ | ︙ | |||
3352 3353 3354 3355 3356 3357 3358 |
/*
* This code is tricky: C doesn't guarantee much
* about the quotient or remainder, but Tcl does.
* The remainder always has the same sign as the
* divisor and a smaller absolute value.
*/
if (w2 == W0) {
| | < | 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 |
/*
* This code is tricky: C doesn't guarantee much
* about the quotient or remainder, but Tcl does.
* The remainder always has the same sign as the
* divisor and a smaller absolute value.
*/
if (w2 == W0) {
TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
goto divideByZero;
}
if (w2 < 0) {
w2 = -w2;
w = -w;
}
wquot = w / w2;
wrem = w % w2;
if (wrem < W0) {
wquot -= 1;
}
wResult = wquot;
break;
}
} else {
/*
* Do integer arithmetic.
*/
switch (*pc) {
case INST_ADD:
iResult = i + i2;
|
| ︙ | ︙ | |||
3415 3416 3417 3418 3419 3420 3421 |
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
if (doDouble) {
objResultPtr = Tcl_NewDoubleObj(dResult);
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
| < | < < | < | 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 |
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
if (doDouble) {
objResultPtr = Tcl_NewDoubleObj(dResult);
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
} else if (doWide) {
objResultPtr = Tcl_NewWideIntObj(wResult);
TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
} else {
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
}
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
if (doDouble) { /* NB: stack top is off by 1 */
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
Tcl_SetDoubleObj(valuePtr, dResult);
} else if (doWide) {
TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
Tcl_SetWideIntObj(valuePtr, wResult);
} else {
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
}
NEXT_INST_F(1, 1, 0);
}
}
|
| ︙ | ︙ | |||
3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 |
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
s, (tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
tPtr = valuePtr->typePtr;
}
/*
* Ensure that the operand's string rep is the same as the
* formatted version of its internal rep. This makes sure
* that "expr +000123" yields "83", not "000123". We
* implement this by _discarding_ the string rep since we
* know it will be regenerated, if needed later, by
* formatting the internal rep's value.
*/
if (Tcl_IsShared(valuePtr)) {
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(i);
| > > < | < | 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 |
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
s, (tPtr? tPtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
tPtr = valuePtr->typePtr;
}
/*
* Ensure that the operand's string rep is the same as the
* formatted version of its internal rep. This makes sure
* that "expr +000123" yields "83", not "000123". We
* implement this by _discarding_ the string rep since we
* know it will be regenerated, if needed later, by
* formatting the internal rep's value.
*/
if (Tcl_IsShared(valuePtr)) {
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(i);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
objResultPtr = Tcl_NewWideIntObj(w);
} else {
d = valuePtr->internalRep.doubleValue;
objResultPtr = Tcl_NewDoubleObj(d);
}
TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
NEXT_INST_F(1, 1, 1);
} else {
|
| ︙ | ︙ | |||
3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 |
result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
valuePtr, &boolvar);
i = (long)boolvar; /* i is long, not int! */
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
s, (tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
}
tPtr = valuePtr->typePtr;
}
if (Tcl_IsShared(valuePtr)) {
/*
* Create a new object.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
| > > < | | < | 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 |
result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
valuePtr, &boolvar);
i = (long)boolvar; /* i is long, not int! */
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
s, (tPtr? tPtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
tPtr = valuePtr->typePtr;
}
if (Tcl_IsShared(valuePtr)) {
/*
* Create a new object.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
if (*pc == INST_UMINUS) {
objResultPtr = Tcl_NewWideIntObj(-w);
} else {
objResultPtr = Tcl_NewLongObj(w == W0);
}
TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
objResultPtr = Tcl_NewDoubleObj(-d);
} else {
/*
* Should be able to use "!d", but apparently
|
| ︙ | ︙ | |||
3588 3589 3590 3591 3592 3593 3594 |
* valuePtr is unshared. Modify it directly.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
Tcl_SetLongObj(valuePtr,
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
| < | | < | 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 |
* valuePtr is unshared. Modify it directly.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
Tcl_SetLongObj(valuePtr,
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
if (*pc == INST_UMINUS) {
Tcl_SetWideIntObj(valuePtr, -w);
} else {
Tcl_SetLongObj(valuePtr, w == W0);
}
TRACE_WITH_OBJ((LLD" => ", w), valuePtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
Tcl_SetDoubleObj(valuePtr, -d);
} else {
/*
* Should be able to use "!d", but apparently
|
| ︙ | ︙ | |||
3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 |
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr)) {
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) { /* try to convert to double */
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
O2S(valuePtr), (tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
}
| > > < | | | < < < | 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 |
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr)) {
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) { /* try to convert to double */
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
O2S(valuePtr), (tPtr? tPtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewWideIntObj(~w);
TRACE(("0x%llx => (%llu)\n", w, ~w));
NEXT_INST_F(1, 1, 1);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
Tcl_SetWideIntObj(valuePtr, ~w);
TRACE(("0x%llx => (%llu)\n", w, ~w));
NEXT_INST_F(1, 0, 0);
}
} else {
i = valuePtr->internalRep.longValue;
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewLongObj(~i);
TRACE(("0x%lx => (%lu)\n", i, ~i));
NEXT_INST_F(1, 1, 1);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
Tcl_SetLongObj(valuePtr, ~i);
TRACE(("0x%lx => (%lu)\n", i, ~i));
NEXT_INST_F(1, 0, 0);
}
}
}
case INST_CALL_BUILTIN_FUNC1:
opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call one of the built-in Tcl math functions.
|
| ︙ | ︙ | |||
3784 3785 3786 3787 3788 3789 3790 |
* We only need to make a copy of the object
* when it already had a string rep
*/
needNew = 1;
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(i);
| < | < > > > > > > | 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 |
* We only need to make a copy of the object
* when it already had a string rep
*/
needNew = 1;
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objResultPtr = Tcl_NewLongObj(i);
} else if (tPtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
objResultPtr = Tcl_NewWideIntObj(w);
} else {
d = valuePtr->internalRep.doubleValue;
objResultPtr = Tcl_NewDoubleObj(d);
}
tPtr = objResultPtr->typePtr;
}
} else {
Tcl_InvalidateStringRep(valuePtr);
}
if (tPtr == &tclDoubleType) {
d = objResultPtr->internalRep.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
O2S(objResultPtr)));
DECACHE_STACK_INFO();
TclExprFloatError(interp, d);
CACHE_STACK_INFO();
result = TCL_ERROR;
goto checkForCatch;
}
}
converted = converted; /* lint, converted not used. */
TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
(converted? "converted" : "not converted"),
(needNew? "new Tcl_Obj" : "same Tcl_Obj")));
} else {
TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
}
if (needNew) {
NEXT_INST_F(1, 1, 1);
} else {
NEXT_INST_F(1, 0, 0);
}
}
case INST_BREAK:
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_BREAK;
cleanup = 0;
goto processExceptionReturn;
case INST_CONTINUE:
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_CONTINUE;
cleanup = 0;
goto processExceptionReturn;
case INST_FOREACH_START4:
opnd = TclGetUInt4AtPtr(pc+1);
{
|
| ︙ | ︙ | |||
3887 3888 3889 3890 3891 3892 3893 | ForeachInfo *infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; ForeachVarList *varListPtr; int numLists = infoPtr->numLists; Var *compiledLocals = iPtr->varFramePtr->compiledLocals; Tcl_Obj *listPtr; | < | 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 | ForeachInfo *infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData; ForeachVarList *varListPtr; int numLists = infoPtr->numLists; Var *compiledLocals = iPtr->varFramePtr->compiledLocals; Tcl_Obj *listPtr; Var *iterVarPtr, *listVarPtr; int iterNum, listTmpIndex, listLen, numVars; int varIndex, valIndex, continueLoop, j; /* * Increment the temp holding the loop iteration number. */ |
| ︙ | ︙ | |||
3941 3942 3943 3944 3945 3946 3947 |
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
| < < | > | > > > > > > > > < | | 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 |
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
Tcl_Obj **elements;
/*
* The call to TclPtrSetVar might shimmer listPtr,
* so re-fetch pointers every iteration for safety.
* See test foreach-10.1.
*/
Tcl_ListObjGetElements(NULL, listPtr,
&listLen, &elements);
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
valuePtr = elements[valIndex];
}
varIndex = varListPtr->varIndexes[j];
varPtr = &(varFramePtr->compiledLocals[varIndex]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
|
| ︙ | ︙ | |||
3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 |
TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = valuePtr;
Tcl_IncrRefCount(valuePtr);
}
} else {
DECACHE_STACK_INFO();
value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
opnd, varIndex),
Tcl_GetObjResult(interp));
| > > < < < | 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 |
TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = valuePtr;
Tcl_IncrRefCount(valuePtr);
}
} else {
DECACHE_STACK_INFO();
Tcl_IncrRefCount(valuePtr);
value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
NULL, valuePtr, TCL_LEAVE_ERR_MSG);
TclDecrRefCount(valuePtr);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
opnd, varIndex),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
}
valIndex++;
}
listTmpIndex++;
|
| ︙ | ︙ | |||
4032 4033 4034 4035 4036 4037 4038 |
result = TCL_OK;
TRACE(("=> catchTop=%d\n", catchTop));
NEXT_INST_F(1, 0, 0);
case INST_PUSH_RESULT:
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
| > > > > > > > > > > > | > > > | 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 |
result = TCL_OK;
TRACE(("=> catchTop=%d\n", catchTop));
NEXT_INST_F(1, 0, 0);
case INST_PUSH_RESULT:
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
/*
* See the comments at INST_INVOKE_STK
*/
{
Tcl_Obj *newObjResultPtr;
TclNewObj(newObjResultPtr);
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
objResultPtr = Tcl_NewLongObj(result);
TRACE(("=> %u\n", result));
NEXT_INST_F(1, 0, 1);
default:
panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
/*
* Division by zero in an expression. Control only reaches this
* point by "goto divideByZero".
*/
divideByZero:
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
(char *) NULL);
CACHE_STACK_INFO();
result = TCL_ERROR;
goto checkForCatch;
/*
* An external evaluation (INST_INVOKE or INST_EVAL) returned
* something different from TCL_OK, or else INST_BREAK or
* INST_CONTINUE were called.
|
| ︙ | ︙ | |||
4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 |
* execution and return the "exception" code.
*/
checkForCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
if (bytes != NULL) {
Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
if (catchTop == -1) {
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %s\n",
| > > | 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 |
* execution and return the "exception" code.
*/
checkForCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
if (bytes != NULL) {
DECACHE_STACK_INFO();
Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
CACHE_STACK_INFO();
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
if (catchTop == -1) {
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %s\n",
|
| ︙ | ︙ | |||
4504 4505 4506 4507 4508 4509 4510 |
"\"", (char *) NULL);
}
}
/*
*----------------------------------------------------------------------
*
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 |
"\"", (char *) NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TclGetSrcInfoForPc, GetSrcInfoForPc --
*
* Given a program counter value, finds the closest command in the
* bytecode code unit's CmdLocation array and returns information about
* that command's source: a pointer to its first byte and the number of
* characters.
*
* Results:
* If a command is found that encloses the program counter value, a
* pointer to the command's source is returned and the length of the
* source is stored at *lengthPtr. If multiple commands resulted in
* code at pc, information about the closest enclosing command is
* returned. If no matching command is found, NULL is returned and
* *lengthPtr is unchanged.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_TIP280
void
TclGetSrcInfoForPc (cfPtr)
CmdFrame* cfPtr;
{
ByteCode* codePtr = (ByteCode*) cfPtr->data.tebc.codePtr;
if (cfPtr->cmd.str.cmd == NULL) {
cfPtr->cmd.str.cmd = GetSrcInfoForPc((char*) cfPtr->data.tebc.pc,
codePtr,
&cfPtr->cmd.str.len);
}
if (cfPtr->cmd.str.cmd != NULL) {
/* We now have the command. We can get the srcOffset back and
* from there find the list of word locations for this command
*/
ExtCmdLoc* eclPtr;
ECL* locPtr = NULL;
int srcOffset;
Interp* iPtr = (Interp*) *codePtr->interpHandle;
Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
if (!hePtr) return;
srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
{
int i;
for (i=0; i < eclPtr->nuloc; i++) {
if (eclPtr->loc [i].srcOffset == srcOffset) {
locPtr = &(eclPtr->loc [i]);
break;
}
}
}
if (locPtr == NULL) {Tcl_Panic ("LocSearch failure");}
cfPtr->line = locPtr->line;
cfPtr->nline = locPtr->nline;
cfPtr->type = eclPtr->type;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
cfPtr->data.eval.path = eclPtr->path;
Tcl_IncrRefCount (cfPtr->data.eval.path);
}
/* Do not set cfPtr->data.eval.path NULL for non-SOURCE
* Needed for cfPtr->data.tebc.codePtr.
*/
}
}
#endif
static char *
GetSrcInfoForPc(pc, codePtr, lengthPtr)
unsigned char *pc; /* The program counter value for which to
* return the closest command's source info.
* This points to a bytecode instruction
* in codePtr's code. */
|
| ︙ | ︙ | |||
4756 4757 4758 4759 4760 4761 4762 |
if (IS_NUMERIC_TYPE(objPtr->typePtr)) {
return TCL_OK;
} else {
int length, result = TCL_OK;
char *s = Tcl_GetStringFromObj(objPtr, &length);
if (TclLooksLikeInt(s, length)) {
| < < < | < | 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 |
if (IS_NUMERIC_TYPE(objPtr->typePtr)) {
return TCL_OK;
} else {
int length, result = TCL_OK;
char *s = Tcl_GetStringFromObj(objPtr, &length);
if (TclLooksLikeInt(s, length)) {
long i;
Tcl_WideInt w;
GET_WIDE_OR_INT(result, objPtr, i, w);
} else {
double d;
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
}
if ((result != TCL_OK) && (interp != NULL)) {
Tcl_ResetResult(interp);
if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
|
| ︙ | ︙ | |||
4973 4974 4975 4976 4977 4978 4979 |
/*
* Push a Tcl object with the result.
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (i < 0) {
| < | < > | | > > > > | > > > > > > > < | > < | 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 |
/*
* Push a Tcl object with the result.
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (i < 0) {
if (i == LONG_MIN) {
#ifdef TCL_WIDE_INT_IS_LONG
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
#else
/*
* Special case: abs(MIN_INT) must promote to wide.
*/
PUSH_OBJECT( Tcl_NewWideIntObj(-(Tcl_WideInt) i) );
result = TCL_OK;
goto done;
#endif
}
iResult = -i;
} else {
iResult = i;
}
PUSH_OBJECT(Tcl_NewLongObj(iResult));
} else if (valuePtr->typePtr == &tclWideIntType) {
Tcl_WideInt wResult, w;
TclGetWide(w,valuePtr);
if (w < W0) {
wResult = -w;
if (wResult < 0) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
}
} else {
wResult = w;
}
PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
dResult = -d;
} else {
dResult = d;
}
|
| ︙ | ︙ | |||
5116 5117 5118 5119 5120 5121 5122 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclIntType) {
iResult = valuePtr->internalRep.longValue;
| < | < | 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclIntType) {
iResult = valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetLongFromWide(iResult,valuePtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
if (d < (double) (long) LONG_MIN) {
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
| ︙ | ︙ | |||
5162 5163 5164 5165 5166 5167 5168 |
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
| < | 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 |
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprWideFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
|
| ︙ | ︙ | |||
5197 5198 5199 5200 5201 5202 5203 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclWideIntType) {
| | | 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 |
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(wResult,valuePtr);
} else if (valuePtr->typePtr == &tclIntType) {
wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue);
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
if (d < Tcl_WideAsDouble(LLONG_MIN)) {
tooLarge:
|
| ︙ | ︙ | |||
5241 5242 5243 5244 5245 5246 5247 |
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
| < | 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 |
*/
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprRandFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
|
| ︙ | ︙ | |||
5354 5355 5356 5357 5358 5359 5360 |
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
| | < | | | < < | < < | > > > > > > > > | < < < < < < < | < > > | > | | < | > | > | | < < | > > > > | < | | > | | | | < < < < > > > > > > > > > > > > > > | 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 |
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Tcl_Obj *valuePtr, *resPtr;
double d, f, i;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if ((valuePtr->typePtr == &tclIntType) ||
(valuePtr->typePtr == &tclWideIntType)) {
result = TCL_OK;
resPtr = valuePtr;
} else {
/*
* Round the number to the nearest integer. I'd like to use round(),
* but it's C99 (or BSD), and not yet universal.
*/
d = valuePtr->internalRep.doubleValue;
f = modf(d, &i);
if (d < 0.0) {
if (f <= -0.5) {
i += -1.0;
}
if (i <= Tcl_WideAsDouble(LLONG_MIN)) {
goto tooLarge;
} else if (i <= (double) LONG_MIN) {
resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
} else {
resPtr = Tcl_NewLongObj((long) i);
}
} else {
if (f >= 0.5) {
i += 1.0;
}
if (i >= Tcl_WideAsDouble(LLONG_MAX)) {
goto tooLarge;
} else if (i >= (double) LONG_MAX) {
resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
} else {
resPtr = Tcl_NewLongObj((long) i);
}
}
}
/*
* Push the result object and free the argument Tcl_Obj.
*/
PUSH_OBJECT(resPtr);
done:
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
/*
* Error return: result cannot be represented as an integer.
*/
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent",
(char *) NULL);
result = TCL_ERROR;
goto done;
}
static int
ExprSrandFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
|
| ︙ | ︙ | |||
5460 5461 5462 5463 5464 5465 5466 |
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
goto badValue;
}
| | < < < | | < < < < < | < < > | | | > > > | 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 |
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
goto badValue;
}
if (Tcl_GetLongFromObj(NULL, valuePtr, &i) != TCL_OK) {
Tcl_WideInt w;
if (Tcl_GetWideIntFromObj(interp, valuePtr, &w) != TCL_OK) {
badValue:
Tcl_AddErrorInfo(interp, "\n (argument to \"srand()\")");
TclDecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return TCL_ERROR;
}
i = Tcl_WideAsLong(w);
}
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
* See comments in ExprRandFunc() for more details.
*/
|
| ︙ | ︙ | |||
5602 5603 5604 5605 5606 5607 5608 |
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = i;
| < < < | > | | < < < | 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 |
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = i;
} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = Tcl_LongAsWide(i);
} else {
args[k].type = TCL_INT;
args[k].intValue = i;
}
} else if (valuePtr->typePtr == &tclWideIntType) {
Tcl_WideInt w;
TclGetWide(w,valuePtr);
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = Tcl_WideAsDouble(w);
} else if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].intValue = Tcl_WideAsLong(w);
} else {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = w;
}
} else {
d = valuePtr->internalRep.doubleValue;
if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].intValue = (long) d;
} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = Tcl_DoubleAsWide(d);
} else {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = d;
}
}
}
|
| ︙ | ︙ | |||
5668 5669 5670 5671 5672 5673 5674 |
/*
* Push the call's object result.
*/
if (funcResult.type == TCL_INT) {
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
| < < | 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 |
/*
* Push the call's object result.
*/
if (funcResult.type == TCL_INT) {
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
} else if (funcResult.type == TCL_WIDE_INT) {
PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue));
} else {
d = funcResult.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
|
| ︙ | ︙ | |||
6210 6211 6212 6213 6214 6215 6216 |
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
return resultStrings[result];
}
TclFormatInt(buf, result);
return buf;
}
#endif /* TCL_COMPILE_DEBUG */
| > > > > > > > > > | 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 |
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
return resultStrings[result];
}
TclFormatInt(buf, result);
return buf;
}
#endif /* TCL_COMPILE_DEBUG */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclFCmd.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclFCmd.c * * This file implements the generic portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclFCmd.c * * This file implements the generic portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclFCmd.c,v 1.20.2.2 2005/08/17 17:46:36 hobbs Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * Declarations for local procedures defined in this file: |
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
if (Tcl_FSStat(target, &statBuf) == 0) {
if (!S_ISDIR(statBuf.st_mode)) {
errno = EEXIST;
errfile = target;
goto done;
}
| | > > > > > > > | > > > > > > > > > > > > > > | | | > > > > > | | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
if (Tcl_FSStat(target, &statBuf) == 0) {
if (!S_ISDIR(statBuf.st_mode)) {
errno = EEXIST;
errfile = target;
goto done;
}
} else if (errno != ENOENT) {
/*
* If Tcl_FSStat() failed and the error is anything
* other than non-existence of the target, throw the
* error.
*/
errfile = target;
goto done;
} else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
/*
* Create might have failed because of being in a race
* condition with another process trying to create the
* same subdirectory.
*/
if (errno == EEXIST) {
if ((Tcl_FSStat(target, &statBuf) == 0)
&& S_ISDIR(statBuf.st_mode)) {
/*
* It is a directory that wasn't there before,
* so keep going without error.
*/
Tcl_ResetResult(interp);
} else {
errfile = target;
goto done;
}
} else {
errfile = target;
goto done;
}
}
/* Forget about this sub-path */
Tcl_DecrRefCount(target);
target = NULL;
}
Tcl_DecrRefCount(split);
split = NULL;
}
done:
if (errfile != NULL) {
Tcl_AppendResult(interp, "can't create directory \"",
Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp),
(char *) NULL);
result = TCL_ERROR;
}
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 661 662 663 664 665 666 667 |
if (result != TCL_OK) {
/*
* We could examine 'errno' to double-check if the problem
* was with the target, but we checked the source above,
* so it should be quite clear
*/
errfile = target;
}
}
if ((copyFlag == 0) && (result == TCL_OK)) {
if (S_ISDIR(sourceStatBuf.st_mode)) {
result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
if (result != TCL_OK) {
if (Tcl_FSEqualPaths(errfile, source) == 0) {
| > > > > > > > > | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 |
if (result != TCL_OK) {
/*
* We could examine 'errno' to double-check if the problem
* was with the target, but we checked the source above,
* so it should be quite clear
*/
errfile = target;
/*
* We now need to reset the result, because the above call,
* if it failed, may have put an error message in place.
* (Ideally we would prefer not to pass an interpreter in
* above, but the channel IO code used by
* TclCrossFilesystemCopy currently requires one)
*/
Tcl_ResetResult(interp);
}
}
if ((copyFlag == 0) && (result == TCL_OK)) {
if (S_ISDIR(sourceStatBuf.st_mode)) {
result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
if (result != TCL_OK) {
if (Tcl_FSEqualPaths(errfile, source) == 0) {
|
| ︙ | ︙ |
Changes to generic/tclFileName.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclFileName.c -- * * This file contains routines for converting file names betwen * native and network form. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclFileName.c -- * * This file contains routines for converting file names betwen * native and network form. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclFileName.c,v 1.40.2.15 2006/10/03 18:20:33 dgp Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclRegexp.h" /* |
| ︙ | ︙ | |||
240 241 242 243 244 245 246 |
Tcl_DStringAppend(resultPtr, path, 2);
Tcl_DStringAppend(resultPtr, "/", 1);
return tail;
}
} else {
int abs = 0;
| | > > | | | | | | | > | > | | > | > | > | > | > | > | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
Tcl_DStringAppend(resultPtr, path, 2);
Tcl_DStringAppend(resultPtr, "/", 1);
return tail;
}
} else {
int abs = 0;
if ((path[0] == 'c' || path[0] == 'C')
&& (path[1] == 'o' || path[1] == 'O')) {
if ((path[2] == 'm' || path[2] == 'M')
&& path[3] >= '1' && path[3] <= '4') {
/* May have match for 'com[1-4]:?', which is a serial port */
if (path[4] == '\0') {
abs = 4;
} else if (path [4] == ':' && path[5] == '\0') {
abs = 5;
}
} else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
/* Have match for 'con' */
abs = 3;
}
} else if ((path[0] == 'l' || path[0] == 'L')
&& (path[1] == 'p' || path[1] == 'P')
&& (path[2] == 't' || path[2] == 'T')) {
if (path[3] >= '1' && path[3] <= '3') {
/* May have match for 'lpt[1-3]:?' */
if (path[4] == '\0') {
abs = 4;
} else if (path [4] == ':' && path[5] == '\0') {
abs = 5;
}
}
} else if ((path[0] == 'p' || path[0] == 'P')
&& (path[1] == 'r' || path[1] == 'R')
&& (path[2] == 'n' || path[2] == 'N')
&& path[3] == '\0') {
/* Have match for 'prn' */
abs = 3;
} else if ((path[0] == 'n' || path[0] == 'N')
&& (path[1] == 'u' || path[1] == 'U')
&& (path[2] == 'l' || path[2] == 'L')
&& path[3] == '\0') {
/* Have match for 'nul' */
abs = 3;
} else if ((path[0] == 'a' || path[0] == 'A')
&& (path[1] == 'u' || path[1] == 'U')
&& (path[2] == 'x' || path[2] == 'X')
&& path[3] == '\0') {
/* Have match for 'aux' */
abs = 3;
}
if (abs != 0) {
*typePtr = TCL_PATH_ABSOLUTE;
Tcl_DStringSetLength(resultPtr, offset);
Tcl_DStringAppend(resultPtr, path, abs);
|
| ︙ | ︙ | |||
778 779 780 781 782 783 784 |
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
}
Tcl_DStringFree(&buf);
/*
| | > | > | > > | 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
}
Tcl_DStringFree(&buf);
/*
* Split on slashes. Embedded elements that start with tilde
* or a drive letter will be prefixed with "./" so they are not
* affected by tilde substitution.
*/
do {
elementStart = p;
while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
p++;
}
length = p - elementStart;
if (length > 0) {
Tcl_Obj *nextElt;
if ((elementStart != path)
&& ((elementStart[0] == '~')
|| (isalpha(UCHAR(elementStart[0]))
&& elementStart[1] == ':'))) {
nextElt = Tcl_NewStringObj("./",2);
Tcl_AppendToObj(nextElt, elementStart, length);
} else {
nextElt = Tcl_NewStringObj(elementStart, length);
}
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
|
| ︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 |
{
int length, needsSep;
char *dest, *p, *start;
start = Tcl_GetStringFromObj(prefix, &length);
/*
| | | | > > > > < < | 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
{
int length, needsSep;
char *dest, *p, *start;
start = Tcl_GetStringFromObj(prefix, &length);
/*
* Remove the ./ from tilde prefixed elements, and drive-letter
* prefixed elements on Windows, unless it is the first component.
*/
p = joining;
if (length != 0) {
if ((p[0] == '.') && (p[1] == '/')
&& ((p[2] == '~')
|| ((tclPlatform == TCL_PLATFORM_WINDOWS)
&& isalpha(UCHAR(p[2]))
&& (p[3] == ':')))) {
p += 2;
}
}
if (*p == '\0') {
return;
}
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
/*
* Append a separator if needed.
*/
|
| ︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 |
* indicate current user's home directory) or
* "~<user>" (to indicate any user's home
* directory). */
Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
* with name after tilde substitution. */
{
Tcl_Obj *path = Tcl_NewStringObj(name, -1);
| | | | > | > | < < < < < < < < < < < < < < < < < < < | 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
* indicate current user's home directory) or
* "~<user>" (to indicate any user's home
* directory). */
Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
* with name after tilde substitution. */
{
Tcl_Obj *path = Tcl_NewStringObj(name, -1);
Tcl_Obj *transPtr;
Tcl_IncrRefCount(path);
transPtr = Tcl_FSGetTranslatedPath(interp, path);
if (transPtr == NULL) {
Tcl_DecrRefCount(path);
return NULL;
}
Tcl_DStringInit(bufferPtr);
Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1);
Tcl_DecrRefCount(path);
Tcl_DecrRefCount(transPtr);
/*
* Convert forward slashes to backslashes in Windows paths because
* some system interfaces don't accept forward slashes.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
register char *p;
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '/') {
*p = '\\';
}
}
}
return Tcl_DStringValue(bufferPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1598 1599 1600 1601 1602 1603 1604 |
enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
Tcl_GlobTypeData *globTypes = NULL;
globFlags = 0;
join = 0;
dir = PATH_NONE;
typePtr = NULL;
| < | 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 |
enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
Tcl_GlobTypeData *globTypes = NULL;
globFlags = 0;
join = 0;
dir = PATH_NONE;
typePtr = NULL;
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
string = Tcl_GetStringFromObj(objv[i], &length);
if (string[0] == '-') {
/*
* It looks like the command contains an option so signal
|
| ︙ | ︙ | |||
1624 1625 1626 1627 1628 1629 1630 |
}
switch (index) {
case GLOB_NOCOMPLAIN: /* -nocomplain */
globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
break;
case GLOB_DIR: /* -dir */
if (i == (objc-1)) {
| | | | | | | | | | | < | | | 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 |
}
switch (index) {
case GLOB_NOCOMPLAIN: /* -nocomplain */
globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
break;
case GLOB_DIR: /* -dir */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-directory\"", -1));
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-directory\" cannot be used with \"-path\"",
-1));
return TCL_ERROR;
}
dir = PATH_DIR;
globFlags |= TCL_GLOBMODE_DIR;
pathOrDir = objv[i+1];
i++;
break;
case GLOB_JOIN: /* -join */
join = 1;
break;
case GLOB_TAILS: /* -tails */
globFlags |= TCL_GLOBMODE_TAILS;
break;
case GLOB_PATH: /* -path */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-path\"", -1));
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-path\" cannot be used with \"-directory\"",
-1));
return TCL_ERROR;
}
dir = PATH_GENERAL;
pathOrDir = objv[i+1];
i++;
break;
case GLOB_TYPE: /* -types */
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-types\"", -1));
return TCL_ERROR;
}
typePtr = objv[i+1];
if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) {
return TCL_ERROR;
}
i++;
break;
case GLOB_LAST: /* -- */
i++;
goto endOfForLoop;
}
}
endOfForLoop:
if (objc - i < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
return TCL_ERROR;
}
if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-tails\" must be used with either \"-directory\" or \"-path\"",
-1));
return TCL_ERROR;
}
separators = NULL; /* lint. */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
|
| ︙ | ︙ | |||
1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 |
/* The whole thing is a prefix */
Tcl_DStringAppend(&pref, first, -1);
pathOrDir = NULL;
} else {
/* Have to split off the end */
Tcl_DStringAppend(&pref, last, first+pathlength-last);
pathOrDir = Tcl_NewStringObj(first, last-first-1);
}
/* Need to quote 'prefix' */
Tcl_DStringInit(&prefix);
search = Tcl_DStringValue(&pref);
while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
Tcl_DStringAppend(&prefix, search, find-search);
Tcl_DStringAppend(&prefix, "\\", 1);
| > > > > > > > > > > | 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 |
/* The whole thing is a prefix */
Tcl_DStringAppend(&pref, first, -1);
pathOrDir = NULL;
} else {
/* Have to split off the end */
Tcl_DStringAppend(&pref, last, first+pathlength-last);
pathOrDir = Tcl_NewStringObj(first, last-first-1);
/*
* We must ensure that we haven't cut off too much,
* and turned a valid path like '/' or 'C:/' into
* an incorrect path like '' or 'C:'. The way we
* do this is to add a separator if there are none
* presently in the prefix.
*/
if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) {
Tcl_AppendToObj(pathOrDir, last-1, 1);
}
}
/* Need to quote 'prefix' */
Tcl_DStringInit(&prefix);
search = Tcl_DStringValue(&pref);
while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
Tcl_DStringAppend(&prefix, search, find-search);
Tcl_DStringAppend(&prefix, "\\", 1);
|
| ︙ | ︙ | |||
1846 1847 1848 1849 1850 1851 1852 | globTypes->macCreator = item; Tcl_IncrRefCount(item); continue; } } } /* | | < | < | < < < < < | 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 |
globTypes->macCreator = item;
Tcl_IncrRefCount(item);
continue;
}
}
}
/*
* Error cases. We reset
* the 'join' flag to zero, since we haven't yet
* made use of it.
*/
badTypesArg:
resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
Tcl_AppendObjToObj(resultPtr, look);
result = TCL_ERROR;
join = 0;
goto endOfGlob;
badMacTypesArg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"only one MacOS type or creator argument"
" to \"-types\" allowed", -1));
result = TCL_ERROR;
join = 0;
goto endOfGlob;
}
}
}
/*
* Now we perform the actual glob below. This may involve joining
* together the pattern arguments, dealing with particular file types
* etc. We use a 'goto' to ensure we free any memory allocated along
* the way.
*/
objc -= i;
objv += i;
result = TCL_OK;
if (join) {
if (dir != PATH_GENERAL) {
Tcl_DStringInit(&prefix);
}
for (i = 0; i < objc; i++) {
string = Tcl_GetStringFromObj(objv[i], &length);
|
| ︙ | ︙ | |||
2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 |
if (strchr(separators, c) == NULL) {
/*
* If the prefix is a directory, make sure it ends in a
* directory separator.
*/
if (globFlags & TCL_GLOBMODE_DIR) {
Tcl_DStringAppend(&buffer,separators,1);
}
prefixLen++;
}
}
/*
* We need to get the old result, in case it is over-written
| > > > > | 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 |
if (strchr(separators, c) == NULL) {
/*
* If the prefix is a directory, make sure it ends in a
* directory separator.
*/
if (globFlags & TCL_GLOBMODE_DIR) {
Tcl_DStringAppend(&buffer,separators,1);
/* Try to borrow that separator from the tail */
if (*tail == *separators) {
tail++;
}
}
prefixLen++;
}
}
/*
* We need to get the old result, in case it is over-written
|
| ︙ | ︙ | |||
2326 2327 2328 2329 2330 2331 2332 |
* Consume any leading directory separators, leaving tail pointing
* just past the last initial separator.
*/
count = 0;
name = tail;
for (; *tail != '\0'; tail++) {
| > > > > > > > > | | > > > > > > > > > > | 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 |
* Consume any leading directory separators, leaving tail pointing
* just past the last initial separator.
*/
count = 0;
name = tail;
for (; *tail != '\0'; tail++) {
if (*tail == '\\') {
/*
* If the first character is escaped, either we have a directory
* separator, or we have any other character. In the latter case
* the rest of tail is a pattern, and we must break from the loop.
* This is particularly important on Windows where '\' is both
* the escaping character and a directory separator.
*/
if (strchr(separators, tail[1]) != NULL) {
tail++;
} else {
break;
}
} else if (strchr(separators, *tail) == NULL) {
break;
}
if (tclPlatform != TCL_PLATFORM_MAC) {
if (*tail == '\\') {
Tcl_DStringAppend(headPtr, separators, 1);
} else {
Tcl_DStringAppend(headPtr, tail, 1);
}
}
count++;
}
/*
* Deal with path separators. On the Mac, we have to watch out
* for multiple separators, since they are special in Mac-style
|
| ︙ | ︙ | |||
2372 2373 2374 2375 2376 2377 2378 | break; case TCL_PLATFORM_WINDOWS: /* * If this is a drive relative path, add the colon and the * trailing slash if needed. Otherwise add the slash if * this is the first absolute element, or a later relative * element. Add an extra slash if this is a UNC path. | < < < < < < < < < < < < < < < < < < < < > | < > > | 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 |
break;
case TCL_PLATFORM_WINDOWS:
/*
* If this is a drive relative path, add the colon and the
* trailing slash if needed. Otherwise add the slash if
* this is the first absolute element, or a later relative
* element. Add an extra slash if this is a UNC path.
if (*name == ':') {
Tcl_DStringAppend(headPtr, ":", 1);
if (count > 1) {
Tcl_DStringAppend(headPtr, "/", 1);
}
} else if ((*tail != '\0')
&& (((length > 0)
&& (strchr(separators, lastChar) == NULL))
|| ((length == 0) && (count > 0)))) {
Tcl_DStringAppend(headPtr, "/", 1);
if ((length == 0) && (count > 1)) {
Tcl_DStringAppend(headPtr, "/", 1);
}
}
*/
break;
case TCL_PLATFORM_UNIX: {
/*
* Add a separator if this is the first absolute element, or
* a later relative element.
if ((*tail != '\0')
&& (((length > 0)
&& (strchr(separators, lastChar) == NULL))
|| ((length == 0) && (count > 0)))) {
Tcl_DStringAppend(headPtr, "/", 1);
}
*/
break;
}
}
/*
* Look for the first matching pair of braces or the first
* directory separator that is not inside a pair of braces.
*/
|
| ︙ | ︙ | |||
2533 2534 2535 2536 2537 2538 2539 |
* each file that matches, it will add the match onto the
* resultPtr given.
*/
if (*p == '\0') {
ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
head, tail, types);
} else {
| < < > | < > > | | 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 |
* each file that matches, it will add the match onto the
* resultPtr given.
*/
if (*p == '\0') {
ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
head, tail, types);
} else {
/*
* We do the recursion ourselves. This makes implementing
* Tcl_FSMatchInDirectory for each filesystem much easier.
*/
Tcl_GlobTypeData dirOnly = { TCL_GLOB_TYPE_DIR, 0, NULL, NULL };
char save = *p;
Tcl_Obj *resultPtr;
resultPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(resultPtr);
*p = '\0';
ret = Tcl_FSMatchInDirectory(interp, resultPtr,
head, tail, &dirOnly);
*p = save;
if (ret == TCL_OK) {
int resLength;
ret = Tcl_ListObjLength(interp, resultPtr, &resLength);
if (ret == TCL_OK) {
int i;
for (i =0; i< resLength; i++) {
Tcl_Obj *elt;
Tcl_DString ds;
Tcl_ListObjIndex(interp, resultPtr, i, &elt);
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1);
if(tclPlatform == TCL_PLATFORM_MAC) {
Tcl_DStringAppend(&ds, ":",1);
} else {
Tcl_DStringAppend(&ds, "/",1);
}
ret = TclDoGlob(interp, separators, &ds, p+1, types);
Tcl_DStringFree(&ds);
if (ret != TCL_OK) {
break;
}
|
| ︙ | ︙ | |||
2605 2606 2607 2608 2609 2610 2611 |
}
break;
}
case TCL_PLATFORM_WINDOWS: {
if (Tcl_DStringLength(headPtr) == 0) {
if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
|| (*name == '/')) {
| | > > > > > > > > > > > | 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 |
}
break;
}
case TCL_PLATFORM_WINDOWS: {
if (Tcl_DStringLength(headPtr) == 0) {
if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
|| (*name == '/')) {
Tcl_DStringAppend(headPtr, "/", 1);
} else {
Tcl_DStringAppend(headPtr, ".", 1);
}
}
#if defined(__CYGWIN__) && defined(__WIN32__)
{
extern int cygwin_conv_to_win32_path
_ANSI_ARGS_((CONST char *, char *));
char winbuf[MAX_PATH+1];
cygwin_conv_to_win32_path(Tcl_DStringValue(headPtr), winbuf);
Tcl_DStringFree(headPtr);
Tcl_DStringAppend(headPtr, winbuf, -1);
}
#endif /* __CYGWIN__ && __WIN32__ */
/*
* Convert to forward slashes. This is required to pass
* some Tcl tests. We should probably remove the conversions
* here and in tclWinFile.c, since they aren't needed since
* the dropping of support for Win32s.
*/
for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
|
| ︙ | ︙ |
Changes to generic/tclGet.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclGet.c -- * * This file contains procedures to convert strings into * other forms, like integers or floating-point numbers or * booleans, doing syntax checking along the way. * * Copyright (c) 1990-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclGet.c -- * * This file contains procedures to convert strings into * other forms, like integers or floating-point numbers or * booleans, doing syntax checking along the way. * * Copyright (c) 1990-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclGet.c,v 1.8.2.1 2005/04/20 16:06:17 dgp Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclMath.h" |
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
/*
* The second test below is needed on platforms where "long" is
* larger than "int" to detect values that fit in a long but not in
* an int.
*/
| | > > > > | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
/*
* The second test below is needed on platforms where "long" is
* larger than "int" to detect values that fit in a long but not in
* an int.
*/
if ((errno == ERANGE)
#if (LONG_MAX > INT_MAX)
|| (i > UINT_MAX) || (i < -(long)UINT_MAX)
#endif
) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_SetResult(interp, "integer value too large to represent",
TCL_STATIC);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
Tcl_GetStringResult(interp), (char *) NULL);
}
return TCL_ERROR;
|
| ︙ | ︙ |
Changes to generic/tclGetDate.y.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclGetDate.y -- * * Contains yacc grammar for parsing date and time strings. * The output of this file should be the file tclDate.c which * is used directly in the Tcl sources. * * Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans. * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
/*
* tclGetDate.y --
*
* Contains yacc grammar for parsing date and time strings.
* The output of this file should be the file tclDate.c which
* is used directly in the Tcl sources.
*
* Copyright (c) 1992-1995 Karl Lehenbauer and Mark Diekhans.
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclGetDate.y,v 1.18.4.2 2005/11/04 20:15:09 kennykb Exp $
*/
%{
/*
* tclDate.c --
*
* This file is generated from a yacc grammar defined in
|
| ︙ | ︙ | |||
549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
{ "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */
#endif /* 0 */
{ "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */
{ "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
{ "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
{ "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
{ "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
{ "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
{ "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
{ "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
{ "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
{ "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */
{ "nzt", tZONE, -HOUR(12) }, /* New Zealand */
{ "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */
| > > > | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 |
{ "sst", tZONE, -HOUR( 7) }, /* South Sumatra, USSR Zone 6 */
#endif /* 0 */
{ "wast", tZONE, -HOUR( 7) }, /* West Australian Standard */
{ "wadt", tDAYZONE, -HOUR( 7) }, /* West Australian Daylight */
{ "jt", tZONE, -HOUR(15/2) }, /* Java (3pm in Cronusland!) */
{ "cct", tZONE, -HOUR( 8) }, /* China Coast, USSR Zone 7 */
{ "jst", tZONE, -HOUR( 9) }, /* Japan Standard, USSR Zone 8 */
{ "jdt", tDAYZONE, -HOUR( 9) }, /* Japan Daylight */
{ "kst", tZONE, -HOUR( 9) }, /* Korea Standard */
{ "kdt", tDAYZONE, -HOUR( 9) }, /* Korea Daylight */
{ "cast", tZONE, -HOUR(19/2) }, /* Central Australian Standard */
{ "cadt", tDAYZONE, -HOUR(19/2) }, /* Central Australian Daylight */
{ "east", tZONE, -HOUR(10) }, /* Eastern Australian Standard */
{ "eadt", tDAYZONE, -HOUR(10) }, /* Eastern Australian Daylight */
{ "gst", tZONE, -HOUR(10) }, /* Guam Standard, USSR Zone 9 */
{ "nzt", tZONE, -HOUR(12) }, /* New Zealand */
{ "nzst", tZONE, -HOUR(12) }, /* New Zealand Standard */
|
| ︙ | ︙ | |||
1047 1048 1049 1050 1051 1052 1053 |
/*
* Specify zone is of -50000 to force GMT. (This allows BST to work).
*/
int
TclGetDate(p, now, zone, timePtr)
char *p;
| | | | | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
/*
* Specify zone is of -50000 to force GMT. (This allows BST to work).
*/
int
TclGetDate(p, now, zone, timePtr)
char *p;
Tcl_WideInt now;
long zone;
Tcl_WideInt *timePtr;
{
struct tm *tm;
time_t Start;
time_t Time;
time_t tod;
int thisyear;
yyInput = p;
/* now has to be cast to a time_t for 64bit compliance */
Start = (time_t) now;
tm = TclpGetDate((TclpTime_t) &Start, (zone == -50000));
thisyear = tm->tm_year + TM_YEAR_BASE;
yyYear = thisyear;
yyMonth = tm->tm_mon + 1;
yyDay = tm->tm_mday;
yyTimezone = zone;
if (zone == -50000) {
yyDSTmode = DSToff; /* assume GMT */
|
| ︙ | ︙ | |||
1119 1120 1121 1122 1123 1124 1125 |
}
}
if (Convert(yyMonth, yyDay, yyYear, yyHour, yyMinutes, yySeconds,
yyMeridian, yyDSTmode, &Start) < 0) {
return -1;
}
} else {
| | | 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 |
}
}
if (Convert(yyMonth, yyDay, yyYear, yyHour, yyMinutes, yySeconds,
yyMeridian, yyDSTmode, &Start) < 0) {
return -1;
}
} else {
Start = (time_t) now;
if (!yyHaveRel) {
Start -= ((tm->tm_hour * 60L * 60L) +
tm->tm_min * 60L) + tm->tm_sec;
}
}
Start += yyRelSeconds;
|
| ︙ | ︙ |
Changes to generic/tclHash.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclHash.c -- * * Implementation of in-memory hash tables for Tcl and Tcl-based * applications. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclHash.c -- * * Implementation of in-memory hash tables for Tcl and Tcl-based * applications. * * Copyright (c) 1991-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclHash.c,v 1.12.2.1 2004/11/11 01:18:07 das Exp $ */ #include "tclInt.h" /* * Prevent macros from clashing with function definitions. */ |
| ︙ | ︙ | |||
312 313 314 315 316 317 318 319 320 321 322 323 324 325 |
}
/*
* Search all of the entries in the appropriate bucket.
*/
if (typePtr->compareKeysProc) {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
if (hash != (unsigned int) hPtr->hash) {
continue;
}
#endif
| > | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
}
/*
* Search all of the entries in the appropriate bucket.
*/
if (typePtr->compareKeysProc) {
Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
if (hash != (unsigned int) hPtr->hash) {
continue;
}
#endif
if (compareKeysProc ((VOID *) key, hPtr)) {
return hPtr;
}
}
} else {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
}
/*
* Search all of the entries in the appropriate bucket.
*/
if (typePtr->compareKeysProc) {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
if (hash != (unsigned int) hPtr->hash) {
continue;
}
#endif
| > | | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 |
}
/*
* Search all of the entries in the appropriate bucket.
*/
if (typePtr->compareKeysProc) {
Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
#if TCL_HASH_KEY_STORE_HASH
if (hash != (unsigned int) hPtr->hash) {
continue;
}
#endif
if (compareKeysProc ((VOID *) key, hPtr)) {
*newPtr = 0;
return hPtr;
}
}
} else {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
|
| ︙ | ︙ | |||
699 700 701 702 703 704 705 706 707 |
Tcl_NextHashEntry(searchPtr)
register Tcl_HashSearch *searchPtr; /* Place to store information about
* progress through the table. Must
* have been initialized by calling
* Tcl_FirstHashEntry. */
{
Tcl_HashEntry *hPtr;
while (searchPtr->nextEntryPtr == NULL) {
| > | | | 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 |
Tcl_NextHashEntry(searchPtr)
register Tcl_HashSearch *searchPtr; /* Place to store information about
* progress through the table. Must
* have been initialized by calling
* Tcl_FirstHashEntry. */
{
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr = searchPtr->tablePtr;
while (searchPtr->nextEntryPtr == NULL) {
if (searchPtr->nextIndex >= tablePtr->numBuckets) {
return NULL;
}
searchPtr->nextEntryPtr =
tablePtr->buckets[searchPtr->nextIndex];
searchPtr->nextIndex++;
}
hPtr = searchPtr->nextEntryPtr;
searchPtr->nextEntryPtr = hPtr->nextPtr;
return hPtr;
}
|
| ︙ | ︙ |
Changes to generic/tclIO.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclIO.c -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * * Copyright (c) 1998-2000 Ajuba Solutions * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | /* * tclIO.c -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * * Copyright (c) 1998-2000 Ajuba Solutions * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIO.c,v 1.61.2.23 2007/05/24 19:31:55 dgp Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclIO.h" #include <assert.h> #ifndef TCL_INHERIT_STD_CHANNELS #define TCL_INHERIT_STD_CHANNELS 1 #endif /* * All static variables used in this file are collected into a single * instance of the following structure. For multi-threaded implementations, * there is one instance of this structure for each thread. * |
| ︙ | ︙ | |||
181 182 183 184 185 186 187 | } /* *------------------------------------------------------------------------- * * TclFinalizeIOSubsystem -- * | | | | > > | > > > > | > > > > > > > > > | | > | > > > > > | > > > > > | | | | | | | | | | | < | | | | | | | | | < | | | | | | | < | < | | | | | | | | | | | | | < | | | | | | | | | > | | | | | | | > > > > | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
}
/*
*-------------------------------------------------------------------------
*
* TclFinalizeIOSubsystem --
*
* Releases all resources used by this subsystem on a per-thread
* basis. Closes all extant channels that have not already been
* closed because they were not owned by any interp.
*
* Results:
* None.
*
* Side effects:
* Depends on encoding and memory subsystems.
*
*-------------------------------------------------------------------------
*/
/* ARGSUSED */
void
TclFinalizeIOSubsystem(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Channel *chanPtr = NULL; /* Iterates over open channels. */
ChannelState *statePtr; /* State of channel stack */
int active = 1; /* Flag == 1 while there's still work to do */
/*
* Walk all channel state structures known to this thread and
* close corresponding channels.
*/
while (active) {
/*
* Iterate through the open channel list, and find the first
* channel that isn't dead. We start from the head of the list
* each time, because the close action on one channel can close
* others.
*/
active = 0;
for (statePtr = tsdPtr->firstCSPtr;
statePtr != NULL;
statePtr = statePtr->nextCSPtr) {
chanPtr = statePtr->topChanPtr;
if (!(statePtr->flags & CHANNEL_DEAD)) {
active = 1;
break;
}
}
/*
* We've found a live channel. Close it.
*/
if (active) {
/*
* Set the channel back into blocking mode to ensure that we
* wait for all data to flush out.
*/
(void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
"-blocking", "on");
if ((chanPtr == (Channel *) tsdPtr->stdinChannel) ||
(chanPtr == (Channel *) tsdPtr->stdoutChannel) ||
(chanPtr == (Channel *) tsdPtr->stderrChannel)) {
/*
* Decrement the refcount which was earlier artificially
* bumped up to keep the channel from being closed.
*/
statePtr->refCount--;
}
if (statePtr->refCount <= 0) {
/*
* Close it only if the refcount indicates that the channel
* is not referenced from any interpreter. If it is, that
* interpreter will close the channel when it gets destroyed.
*/
(void) Tcl_Close(NULL, (Tcl_Channel) chanPtr);
} else {
/*
* The refcount is greater than zero, so flush the channel.
*/
Tcl_Flush((Tcl_Channel) chanPtr);
/*
* Call the device driver to actually close the underlying
* device for this channel.
*/
if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) {
(chanPtr->typePtr->closeProc)(chanPtr->instanceData, NULL);
} else {
(chanPtr->typePtr->close2Proc)(chanPtr->instanceData,
NULL, 0);
}
/*
* Finally, we clean up the fields in the channel data
* structure since all of them have been deleted already.
* We mark the channel with CHANNEL_DEAD to prevent any
* further IO operations
* on it.
*/
chanPtr->instanceData = NULL;
statePtr->flags |= CHANNEL_DEAD;
}
}
}
TclpFinalizeSockets();
TclpFinalizePipes();
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetStdChannel --
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 775 776 777 778 779 780 781 |
return;
}
panic("Tcl_RegisterChannel: duplicate channel names");
}
Tcl_SetHashValue(hPtr, (ClientData) chanPtr);
}
statePtr->refCount++;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnregisterChannel --
| > | 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 |
return;
}
panic("Tcl_RegisterChannel: duplicate channel names");
}
Tcl_SetHashValue(hPtr, (ClientData) chanPtr);
}
statePtr->refCount++;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnregisterChannel --
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 811 812 813 814 815 816 817 |
int
Tcl_UnregisterChannel(interp, chan)
Tcl_Interp *interp; /* Interpreter in which channel is defined. */
Tcl_Channel chan; /* Channel to delete. */
{
ChannelState *statePtr; /* State of the real channel. */
if (DetachChannel(interp, chan) != TCL_OK) {
return TCL_OK;
}
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
/*
| > > > > > > > > > > > | 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
int
Tcl_UnregisterChannel(interp, chan)
Tcl_Interp *interp; /* Interpreter in which channel is defined. */
Tcl_Channel chan; /* Channel to delete. */
{
ChannelState *statePtr; /* State of the real channel. */
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
if (statePtr->flags & CHANNEL_INCLOSE) {
if (interp != (Tcl_Interp*) NULL) {
Tcl_AppendResult(interp,
"Illegal recursive call to close through close-handler of channel",
(char *) NULL);
}
return TCL_ERROR;
}
if (DetachChannel(interp, chan) != TCL_OK) {
return TCL_OK;
}
statePtr = ((Channel *) chan)->state->bottomChanPtr->state;
/*
|
| ︙ | ︙ | |||
1192 1193 1194 1195 1196 1197 1198 |
/*
* Link the channel into the list of all channels; create an on-exit
* handler if there is not one already, to close off all the channels
* in the list on exit.
*
* JH: Could call Tcl_SpliceChannel, but need to avoid NULL check.
| < | > | | | < | | > | | > | | > | 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 |
/*
* Link the channel into the list of all channels; create an on-exit
* handler if there is not one already, to close off all the channels
* in the list on exit.
*
* JH: Could call Tcl_SpliceChannel, but need to avoid NULL check.
*
* TIP #218.
* AK: Just initialize the field to NULL before invoking Tcl_SpliceChannel
* We need Tcl_SpliceChannel, for the threadAction calls.
* There is no real reason to duplicate all of this.
* NOTE: All drivers using thread actions now have to perform their TSD
* manipulation only in their thread action proc. Doing it when
* creating their instance structures will collide with the thread
* action activity and lead to damaged lists.
*/
statePtr->nextCSPtr = (ChannelState *) NULL;
Tcl_SpliceChannel ((Tcl_Channel) chanPtr);
/*
* Install this channel in the first empty standard channel slot, if
* the channel was previously closed explicitly.
*/
#if TCL_INHERIT_STD_CHANNELS
if ((tsdPtr->stdinChannel == NULL) &&
(tsdPtr->stdinInitialized == 1)) {
Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN);
Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
} else if ((tsdPtr->stdoutChannel == NULL) &&
(tsdPtr->stdoutInitialized == 1)) {
Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDOUT);
Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
} else if ((tsdPtr->stderrChannel == NULL) &&
(tsdPtr->stderrInitialized == 1)) {
Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR);
Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr);
}
#endif
return (Tcl_Channel) chanPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StackChannel --
|
| ︙ | ︙ | |||
1280 1281 1282 1283 1284 1285 1286 |
*
* This operation should occur at the top of a channel stack.
*/
statePtr = (ChannelState *) tsdPtr->firstCSPtr;
prevChanPtr = ((Channel *) prevChan)->state->topChanPtr;
| | > | | > > | | | > > | | > | 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 |
*
* This operation should occur at the top of a channel stack.
*/
statePtr = (ChannelState *) tsdPtr->firstCSPtr;
prevChanPtr = ((Channel *) prevChan)->state->topChanPtr;
while ((statePtr != NULL) && (statePtr->topChanPtr != prevChanPtr)) {
statePtr = statePtr->nextCSPtr;
}
if (statePtr == NULL) {
if (interp) {
Tcl_AppendResult(interp, "couldn't find state for channel \"",
Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
}
return (Tcl_Channel) NULL;
}
/*
* Here we check if the given "mask" matches the "flags"
* of the already existing channel.
*
* | - | R | W | RW |
* --+---+---+---+----+ <=> 0 != (chan->mask & prevChan->mask)
* - | | | | |
* R | | + | | + | The superceding channel is allowed to
* W | | | + | + | restrict the capabilities of the
* RW| | + | + | + | superceded one !
* --+---+---+---+----+
*/
if ((mask & (statePtr->flags & (TCL_READABLE | TCL_WRITABLE))) == 0) {
if (interp) {
Tcl_AppendResult(interp,
"reading and writing both disallowed for channel \"",
Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
}
return (Tcl_Channel) NULL;
}
/*
* Flush the buffers. This ensures that any data still in them
* at this time is not handled by the new transformation. Restrict
* this to writable channels. Take care to hide a possible bg-copy
* in progress from Tcl_Flush and the CheckForChannelErrors inside.
*/
if ((mask & TCL_WRITABLE) != 0) {
CopyState *csPtr;
csPtr = statePtr->csPtr;
statePtr->csPtr = (CopyState*) NULL;
if (Tcl_Flush((Tcl_Channel) prevChanPtr) != TCL_OK) {
statePtr->csPtr = csPtr;
if (interp) {
Tcl_AppendResult(interp, "could not flush channel \"",
Tcl_GetChannelName(prevChan), "\"", (char *) NULL);
}
return (Tcl_Channel) NULL;
}
statePtr->csPtr = csPtr;
}
/*
* Discard any input in the buffers. They are not yet read by the
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 |
CopyState* csPtr;
csPtr = statePtr->csPtr;
statePtr->csPtr = (CopyState*) NULL;
if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) {
statePtr->csPtr = csPtr;
| > | | | > | 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 |
CopyState* csPtr;
csPtr = statePtr->csPtr;
statePtr->csPtr = (CopyState*) NULL;
if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) {
statePtr->csPtr = csPtr;
if (interp) {
Tcl_AppendResult(interp, "could not flush channel \"",
Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"",
(char *) NULL);
}
return TCL_ERROR;
}
statePtr->csPtr = csPtr;
}
/*
|
| ︙ | ︙ | |||
2362 2363 2364 2365 2366 2367 2368 | * Results: * Nothing. * * Side effects: * Resets the field 'nextCSPtr' of the specified channel state to NULL. * * NOTE: | | | 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 | * Results: * Nothing. * * Side effects: * Resets the field 'nextCSPtr' of the specified channel state to NULL. * * NOTE: * The channel to cut out of the list must not be referenced * in any interpreter. This is something this procedure cannot * check (despite the refcount) because the caller usually wants * fiddle with the channel (like transfering it to a different * thread) and thus keeps the refcount artifically high to prevent * its destruction. * *---------------------------------------------------------------------- |
| ︙ | ︙ | |||
2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 |
{
ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelState *prevCSPtr; /* Preceding channel state in list of
* all states - used to splice a
* channel out of the list on close. */
ChannelState *statePtr = ((Channel *) chan)->state;
/* state of the channel stack. */
/*
* Remove this channel from of the list of all channels
* (in the current thread).
*/
if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) {
| > | 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 |
{
ThreadSpecificData* tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelState *prevCSPtr; /* Preceding channel state in list of
* all states - used to splice a
* channel out of the list on close. */
ChannelState *statePtr = ((Channel *) chan)->state;
/* state of the channel stack. */
Tcl_DriverThreadActionProc *threadActionProc;
/*
* Remove this channel from of the list of all channels
* (in the current thread).
*/
if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) {
|
| ︙ | ︙ | |||
2406 2407 2408 2409 2410 2411 2412 |
panic("FlushChannel: damaged channel list");
}
prevCSPtr->nextCSPtr = statePtr->nextCSPtr;
}
statePtr->nextCSPtr = (ChannelState *) NULL;
| | > > > > > | > | > > > > > | 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 |
panic("FlushChannel: damaged channel list");
}
prevCSPtr->nextCSPtr = statePtr->nextCSPtr;
}
statePtr->nextCSPtr = (ChannelState *) NULL;
/* TIP #218, Channel Thread Actions */
threadActionProc = Tcl_ChannelThreadActionProc (Tcl_GetChannelType (chan));
if (threadActionProc != NULL) {
(*threadActionProc) (Tcl_GetChannelInstanceData(chan),
TCL_CHANNEL_THREAD_REMOVE);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SpliceChannel --
*
* Adds a channel to the (thread-)global list of all channels
* (in that thread). Expects that the field 'nextChanPtr' in
* the channel is set to NULL.
*
* Results:
* Nothing.
*
* Side effects:
* Nothing.
*
* NOTE:
* The channel to splice into the list must not be referenced in any
* interpreter. This is something this procedure cannot check
* (despite the refcount) because the caller usually wants figgle
* with the channel (like transfering it to a different thread)
* and thus keeps the refcount artifically high to prevent its
* destruction.
*
*----------------------------------------------------------------------
*/
void
Tcl_SpliceChannel(chan)
Tcl_Channel chan; /* The channel being added. Must
* not be referenced in any
* interpreter. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ChannelState *statePtr = ((Channel *) chan)->state;
Tcl_DriverThreadActionProc *threadActionProc;
if (statePtr->nextCSPtr != (ChannelState *) NULL) {
panic("Tcl_SpliceChannel: trying to add channel used in different list");
}
statePtr->nextCSPtr = tsdPtr->firstCSPtr;
tsdPtr->firstCSPtr = statePtr;
/*
* TIP #10. Mark the current thread as the new one managing this
* channel. Note: 'Tcl_GetCurrentThread' returns sensible
* values even for a non-threaded core.
*/
statePtr->managingThread = Tcl_GetCurrentThread ();
/* TIP #218, Channel Thread Actions */
threadActionProc = Tcl_ChannelThreadActionProc (Tcl_GetChannelType (chan));
if (threadActionProc != NULL) {
(*threadActionProc) (Tcl_GetChannelInstanceData(chan),
TCL_CHANNEL_THREAD_INSERT);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_Close --
*
|
| ︙ | ︙ | |||
2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 |
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
if (statePtr->refCount > 0) {
panic("called Tcl_Close on channel with refCount > 0");
}
/*
* When the channel has an escape sequence driven encoding such as
* iso2022, the terminated escape sequence must write to the buffer.
*/
if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
| > > > > > > > > > > | 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 |
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
if (statePtr->refCount > 0) {
panic("called Tcl_Close on channel with refCount > 0");
}
if (statePtr->flags & CHANNEL_INCLOSE) {
if (interp) {
Tcl_AppendResult(interp,
"Illegal recursive call to close through close-handler of channel",
(char *) NULL);
}
return TCL_ERROR;
}
statePtr->flags |= CHANNEL_INCLOSE;
/*
* When the channel has an escape sequence driven encoding such as
* iso2022, the terminated escape sequence must write to the buffer.
*/
if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL)
&& (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) {
|
| ︙ | ︙ | |||
2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 |
while (statePtr->closeCbPtr != (CloseCallback *) NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
(cbPtr->proc) (cbPtr->clientData);
ckfree((char *) cbPtr);
}
/*
* Ensure that the last output buffer will be flushed.
*/
if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
(statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) {
| > > | 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 |
while (statePtr->closeCbPtr != (CloseCallback *) NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
(cbPtr->proc) (cbPtr->clientData);
ckfree((char *) cbPtr);
}
statePtr->flags &= ~CHANNEL_INCLOSE;
/*
* Ensure that the last output buffer will be flushed.
*/
if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) &&
(statePtr->curOutPtr->nextAdded > statePtr->curOutPtr->nextRemoved)) {
|
| ︙ | ︙ | |||
2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 |
* This operation should occur at the top of a channel stack.
*/
chanPtr = (Channel *) channel;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
/*
* Remove any references to channel handlers for this channel that
* may be about to be invoked.
*/
for (nhPtr = tsdPtr->nestedHandlerPtr;
nhPtr != (NextChannelHandler *) NULL;
| > > > > > > | 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 |
* This operation should occur at the top of a channel stack.
*/
chanPtr = (Channel *) channel;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
/*
* Cancel any outstanding timer.
*/
Tcl_DeleteTimerHandler(statePtr->timer);
/*
* Remove any references to channel handlers for this channel that
* may be about to be invoked.
*/
for (nhPtr = tsdPtr->nestedHandlerPtr;
nhPtr != (NextChannelHandler *) NULL;
|
| ︙ | ︙ | |||
2657 2658 2659 2660 2661 2662 2663 |
/*
* Must set the interest mask now to 0, otherwise infinite loops
* will occur if Tcl_DoOneEvent is called before the channel is
* finally deleted in FlushChannel. This can happen if the channel
* has a background flush active.
*/
| | | | 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 |
/*
* Must set the interest mask now to 0, otherwise infinite loops
* will occur if Tcl_DoOneEvent is called before the channel is
* finally deleted in FlushChannel. This can happen if the channel
* has a background flush active.
*/
statePtr->interestMask = 0;
/*
* Remove any EventScript records for this channel.
*/
for (ePtr = statePtr->scriptRecordPtr;
ePtr != (EventScriptRecord *) NULL;
ePtr = eNextPtr) {
|
| ︙ | ︙ | |||
4221 4222 4223 4224 4225 4226 4227 |
if (statePtr->flags & CHANNEL_BLOCKED) {
if (statePtr->flags & CHANNEL_NONBLOCKING) {
goto done;
}
statePtr->flags &= (~(CHANNEL_BLOCKED));
}
| > > > > > > > > | > | > > > > > > > > > > > > > | 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 |
if (statePtr->flags & CHANNEL_BLOCKED) {
if (statePtr->flags & CHANNEL_NONBLOCKING) {
goto done;
}
statePtr->flags &= (~(CHANNEL_BLOCKED));
}
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/* [SF Tcl Bug 943274]. Better emulation of non-blocking
* channels for channels without BlockModeProc, by keeping
* track of true fileevents generated by the OS == Data
* waiting and reading if and only if we are sure to have
* data.
*/
if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
!(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
/* We bypass the driver, it would block, as no data is available */
nread = -1;
result = EWOULDBLOCK;
} else {
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
/*
* Now go to the driver to get as much as is possible to
* fill the remaining request. Do all the error handling
* by ourselves. The code was stolen from 'GetInput' and
* slightly adapted (different return value here).
*
* The case of 'bytesToRead == 0' at this point cannot happen.
*/
nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
bufPtr + copied, bytesToRead - copied, &result);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
if (nread > 0) {
/*
* If we get a short read, signal up that we may be
* BLOCKED. We should avoid calling the driver because
* on some platforms we will block in the low level
* reading code even though the channel is set into
* nonblocking mode.
*/
if (nread < (bytesToRead - copied)) {
statePtr->flags |= CHANNEL_BLOCKED;
}
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
if (nread <= (bytesToRead - copied)) {
/* [SF Tcl Bug 943274] We have read the available
* data, clear flag */
statePtr->flags &= ~CHANNEL_HAS_MORE_DATA;
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
} else if (nread == 0) {
statePtr->flags |= CHANNEL_EOF;
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
} else if (nread < 0) {
if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
if (copied > 0) {
/*
|
| ︙ | ︙ | |||
4374 4375 4376 4377 4378 4379 4380 |
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
int offset, factor, copied, copiedNow, result;
Tcl_Encoding encoding;
#define UTF_EXPANSION_FACTOR 1024
| | | 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 |
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
int offset, factor, copied, copiedNow, result;
Tcl_Encoding encoding;
#define UTF_EXPANSION_FACTOR 1024
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
encoding = statePtr->encoding;
factor = UTF_EXPANSION_FACTOR;
|
| ︙ | ︙ | |||
4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 |
* based on the data seen so far. */
{
int toRead, factor, offset, spaceLeft, length, srcLen, dstNeeded;
int srcRead, dstWrote, numChars, dstRead;
ChannelBuffer *bufPtr;
char *src, *dst;
Tcl_EncodingState oldState;
factor = *factorPtr;
offset = *offsetPtr;
bufPtr = statePtr->inQueueHead;
| > | | 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 |
* based on the data seen so far. */
{
int toRead, factor, offset, spaceLeft, length, srcLen, dstNeeded;
int srcRead, dstWrote, numChars, dstRead;
ChannelBuffer *bufPtr;
char *src, *dst;
Tcl_EncodingState oldState;
int encEndFlagSuppressed = 0;
factor = *factorPtr;
offset = *offsetPtr;
bufPtr = statePtr->inQueueHead;
src = bufPtr->buf + bufPtr->nextRemoved;
srcLen = bufPtr->nextAdded - bufPtr->nextRemoved;
toRead = charsToRead;
if ((unsigned)toRead > (unsigned)srcLen) {
toRead = srcLen;
}
|
| ︙ | ︙ | |||
4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 |
* enough space, convert it using all available space in object
* rather than using the factor.
*/
dstNeeded = spaceLeft;
}
dst = objPtr->bytes + offset;
oldState = statePtr->inputEncodingState;
if (statePtr->flags & INPUT_NEED_NL) {
/*
* We want a '\n' because the last character we saw was '\r'.
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 |
* enough space, convert it using all available space in object
* rather than using the factor.
*/
dstNeeded = spaceLeft;
}
dst = objPtr->bytes + offset;
/*
* SF Tcl Bug 1462248
* The cause of the crash reported in the referenced bug is this:
*
* - ReadChars, called with a single buffer, with a incomplete
* multi-byte character at the end (only the first byte of it).
* - Encoding translation fails, asks for more data
* - Data is read, and eof is reached, TCL_ENCODING_END (TEE) is set.
* - ReadChar is called again, converts the first buffer, but due
* to TEE it does not check for incomplete multi-byte data, and the
* character just after the end of the first buffer is a valid
* completion of the multi-byte header in the actual buffer. The
* conversion reads more characters from the buffer then present.
* This causes nextRemoved to overshoot nextAdded and the next
* reads compute a negative srcLen, cause further translations to
* fail, causing copying of data into the next buffer using bad
* arguments, causing the mecpy for to eventually fail.
*
* In the end it is a memory access bug spiraling out of control
* if the conditions are _just so_. And ultimate cause is that TEE
* is given to a conversion where it should not. TEE signals that
* this is the last buffer. Except in our case it is not.
*
* My solution is to suppress TEE if the first buffer is not the
* last. We will eventually need it given that EOF has been
* reached, but not right now. This is what the new flag
* "endEncSuppressFlag" is for.
*
* The bug in 'Tcl_Utf2UtfProc' where it read from memory behind
* the actual buffer has been fixed as well, and fixes the problem
* with the crash too, but this would still allow the generic
* layer to accidentially break a multi-byte sequence if the
* conditions are just right, because again the ExternalToUtf
* would be successful where it should not.
*/
if ((statePtr->inputEncodingFlags & TCL_ENCODING_END) &&
(bufPtr->nextPtr != NULL)) {
/* TEE is set for a buffer which is not the last. Squash it
* for now, and restore it later, before yielding control to
* our caller.
*/
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
encEndFlagSuppressed = 1;
}
oldState = statePtr->inputEncodingState;
if (statePtr->flags & INPUT_NEED_NL) {
/*
* We want a '\n' because the last character we saw was '\r'.
*/
|
| ︙ | ︙ | |||
4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 |
* The next char was not a '\n'. Produce a '\r'.
*/
*dst = '\r';
}
statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;
*offsetPtr += 1;
return 1;
}
Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst,
dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
if (srcRead == 0) {
/*
* Not enough bytes in src buffer to make a complete char. Copy
* the bytes to the next buffer to make a new contiguous string,
* then tell the caller to fill the buffer with more bytes.
*/
| > > > > > > > > > | 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 |
* The next char was not a '\n'. Produce a '\r'.
*/
*dst = '\r';
}
statePtr->inputEncodingFlags &= ~TCL_ENCODING_START;
*offsetPtr += 1;
if (encEndFlagSuppressed) {
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
}
return 1;
}
Tcl_ExternalToUtf(NULL, statePtr->encoding, src, srcLen,
statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst,
dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars);
if (encEndFlagSuppressed) {
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
}
if (srcRead == 0) {
/*
* Not enough bytes in src buffer to make a complete char. Copy
* the bytes to the next buffer to make a new contiguous string,
* then tell the caller to fill the buffer with more bytes.
*/
|
| ︙ | ︙ | |||
4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 |
* was complete.
*/
statePtr->flags |= CHANNEL_NEED_MORE_DATA;
}
return -1;
}
nextPtr->nextRemoved -= srcLen;
memcpy((VOID *) (nextPtr->buf + nextPtr->nextRemoved), (VOID *) src,
(size_t) srcLen);
RecycleBuffer(statePtr, bufPtr, 0);
statePtr->inQueueHead = nextPtr;
return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr);
}
| > > > > > > > > > > > > > > > > > | 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 |
* was complete.
*/
statePtr->flags |= CHANNEL_NEED_MORE_DATA;
}
return -1;
}
/* Space is made at the beginning of the buffer to copy the
* previous unused bytes there. Check first if the buffer we
* are using actually has enough space at its beginning for
* the data we are copying. Because if not we will write over the
* buffer management information, especially the 'nextPtr'.
*
* Note that the BUFFER_PADDING (See AllocChannelBuffer) is
* used to prevent exactly this situation. I.e. it should
* never happen. Therefore it is ok to panic should it happen
* despite the precautions.
*/
if (nextPtr->nextRemoved - srcLen < 0) {
Tcl_Panic ("Buffer Underflow, BUFFER_PADDING not enough");
}
nextPtr->nextRemoved -= srcLen;
memcpy((VOID *) (nextPtr->buf + nextPtr->nextRemoved), (VOID *) src,
(size_t) srcLen);
RecycleBuffer(statePtr, bufPtr, 0);
statePtr->inQueueHead = nextPtr;
return ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr);
}
|
| ︙ | ︙ | |||
5037 5038 5039 5040 5041 5042 5043 |
if (statePtr->flags & CHANNEL_STICKY_EOF) {
goto done;
}
statePtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF));
bufPtr = AllocChannelBuffer(len);
for (i = 0; i < len; i++) {
| | < | 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 |
if (statePtr->flags & CHANNEL_STICKY_EOF) {
goto done;
}
statePtr->flags &= (~(CHANNEL_BLOCKED | CHANNEL_EOF));
bufPtr = AllocChannelBuffer(len);
for (i = 0; i < len; i++) {
bufPtr->buf[bufPtr->nextAdded++] = str[i];
}
if (statePtr->inQueueHead == (ChannelBuffer *) NULL) {
bufPtr->nextPtr = (ChannelBuffer *) NULL;
statePtr->inQueueHead = bufPtr;
statePtr->inQueueTail = bufPtr;
} else if (atEnd) {
bufPtr->nextPtr = (ChannelBuffer *) NULL;
|
| ︙ | ︙ | |||
5291 5292 5293 5294 5295 5296 5297 |
* platforms it is impossible to read from a device after EOF.
*/
if (statePtr->flags & CHANNEL_EOF) {
return 0;
}
| > > > > > > > | > | > > > > | > > > > > > > > > > > > | 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 |
* platforms it is impossible to read from a device after EOF.
*/
if (statePtr->flags & CHANNEL_EOF) {
return 0;
}
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/* [SF Tcl Bug 943274]. Better emulation of non-blocking channels
* for channels without BlockModeProc, by keeping track of true
* fileevents generated by the OS == Data waiting and reading if
* and only if we are sure to have data.
*/
if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
!(statePtr->flags & CHANNEL_HAS_MORE_DATA)) {
/* Bypass the driver, it would block, as no data is available */
nread = -1;
result = EWOULDBLOCK;
} else {
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData,
bufPtr->buf + bufPtr->nextAdded, toRead, &result);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
if (nread > 0) {
bufPtr->nextAdded += nread;
/*
* If we get a short read, signal up that we may be BLOCKED. We
* should avoid calling the driver because on some platforms we
* will block in the low level reading code even though the
* channel is set into nonblocking mode.
*/
if (nread < toRead) {
statePtr->flags |= CHANNEL_BLOCKED;
}
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
if (nread <= toRead) {
/* [SF Tcl Bug 943274] We have read the available data,
* clear flag */
statePtr->flags &= ~CHANNEL_HAS_MORE_DATA;
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
} else if (nread == 0) {
statePtr->flags |= CHANNEL_EOF;
statePtr->inputEncodingFlags |= TCL_ENCODING_END;
} else if (nread < 0) {
if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
statePtr->flags |= CHANNEL_BLOCKED;
result = EAGAIN;
|
| ︙ | ︙ | |||
5473 5474 5475 5476 5477 5478 5479 |
if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
chanPtr->typePtr->wideSeekProc != NULL) {
curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
offset, mode, &result);
} else if (offset < Tcl_LongAsWide(LONG_MIN) ||
offset > Tcl_LongAsWide(LONG_MAX)) {
| | > | | < | 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 |
if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) &&
chanPtr->typePtr->wideSeekProc != NULL) {
curPos = (chanPtr->typePtr->wideSeekProc) (chanPtr->instanceData,
offset, mode, &result);
} else if (offset < Tcl_LongAsWide(LONG_MIN) ||
offset > Tcl_LongAsWide(LONG_MAX)) {
result = EOVERFLOW;
curPos = Tcl_LongAsWide(-1);
} else {
curPos = Tcl_LongAsWide((chanPtr->typePtr->seekProc) (
chanPtr->instanceData, Tcl_WideAsLong(offset), mode,
&result));
}
if (curPos == Tcl_LongAsWide(-1)) {
Tcl_SetErrno(result);
}
}
/*
* Restore to nonblocking mode if that was the previous behavior.
*
* NOTE: Even if there was an async flush active we do not restore
|
| ︙ | ︙ | |||
5914 5915 5916 5917 5918 5919 5920 | /* *---------------------------------------------------------------------- * * Tcl_SetChannelBufferSize -- * * Sets the size of buffers to allocate to store input or output | | | | | 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 |
/*
*----------------------------------------------------------------------
*
* Tcl_SetChannelBufferSize --
*
* Sets the size of buffers to allocate to store input or output
* in the channel. The size must be between 1 byte and 1 MByte.
*
* Results:
* None.
*
* Side effects:
* Sets the size of buffers subsequently allocated for this channel.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetChannelBufferSize(chan, sz)
Tcl_Channel chan; /* The channel whose buffer size
* to set. */
int sz; /* The size to set. */
{
ChannelState *statePtr; /* State of real channel structure. */
/*
* If the buffer size is smaller than 1 byte or larger than one MByte,
* do not accept the requested size and leave the current buffer size.
*/
if (sz < 1) {
return;
}
if (sz > (1024 * 1024)) {
return;
}
statePtr = ((Channel *) chan)->state;
|
| ︙ | ︙ | |||
6389 6390 6391 6392 6393 6394 6395 |
(char *) NULL);
return TCL_ERROR;
}
}
return TCL_OK;
} else if ((len > 7) && (optionName[1] == 'b') &&
(strncmp(optionName, "-buffersize", len) == 0)) {
| | | | | > | 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 |
(char *) NULL);
return TCL_ERROR;
}
}
return TCL_OK;
} else if ((len > 7) && (optionName[1] == 'b') &&
(strncmp(optionName, "-buffersize", len) == 0)) {
int newBufferSize;
if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_SetChannelBufferSize(chan, newBufferSize);
} else if ((len > 2) && (optionName[1] == 'e') &&
(strncmp(optionName, "-encoding", len) == 0)) {
Tcl_Encoding encoding;
if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) {
encoding = NULL;
} else {
|
| ︙ | ︙ | |||
6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 |
if (statePtr->flags & TCL_WRITABLE) {
statePtr->outEofChar = (int) argv[1][0];
}
}
if (argv != NULL) {
ckfree((char *) argv);
}
return TCL_OK;
} else if ((len > 1) && (optionName[1] == 't') &&
(strncmp(optionName, "-translation", len) == 0)) {
CONST char *readMode, *writeMode;
if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
| > > > > > > > > > | 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 6678 6679 6680 6681 |
if (statePtr->flags & TCL_WRITABLE) {
statePtr->outEofChar = (int) argv[1][0];
}
}
if (argv != NULL) {
ckfree((char *) argv);
}
/*
* [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing
* the character which signals eof can transform a current eof
* condition into a 'go ahead'. Ditto for blocked.
*/
statePtr->flags &= (~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED));
return TCL_OK;
} else if ((len > 1) && (optionName[1] == 't') &&
(strncmp(optionName, "-translation", len) == 0)) {
CONST char *readMode, *writeMode;
if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 |
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelHandler *chPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
NextChannelHandler nh;
Channel* upChanPtr;
Tcl_ChannelType* upTypePtr;
/*
* In contrast to the other API functions this procedure walks towards
* the top of a stack and not down from it.
*
* The channel calling this procedure is the one who generated the event,
* and thus does not take part in handling it. IOW, its HandlerProc is
* not called, instead we begin with the channel above it.
| > > > > > > > > > > > > > > > > | 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 |
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelHandler *chPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
NextChannelHandler nh;
Channel* upChanPtr;
Tcl_ChannelType* upTypePtr;
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/* [SF Tcl Bug 943274]
* For a non-blocking channel without blockmodeproc we keep track
* of actual input coming from the OS so that we can do a credible
* imitation of non-blocking behaviour.
*/
if ((mask & TCL_READABLE) &&
(statePtr->flags & CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) &&
!(statePtr->flags & CHANNEL_TIMER_FEV)) {
statePtr->flags |= CHANNEL_HAS_MORE_DATA;
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
/*
* In contrast to the other API functions this procedure walks towards
* the top of a stack and not down from it.
*
* The channel calling this procedure is the one who generated the event,
* and thus does not take part in handling it. IOW, its HandlerProc is
* not called, instead we begin with the channel above it.
|
| ︙ | ︙ | |||
6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 |
if (mask & TCL_READABLE) {
if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA)
&& (statePtr->inQueueHead != (ChannelBuffer *) NULL)
&& (statePtr->inQueueHead->nextRemoved <
statePtr->inQueueHead->nextAdded)) {
mask &= ~TCL_READABLE;
if (!statePtr->timer) {
statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
(ClientData) chanPtr);
}
}
}
(chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask);
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 7107 7108 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 |
if (mask & TCL_READABLE) {
if (!(statePtr->flags & CHANNEL_NEED_MORE_DATA)
&& (statePtr->inQueueHead != (ChannelBuffer *) NULL)
&& (statePtr->inQueueHead->nextRemoved <
statePtr->inQueueHead->nextAdded)) {
mask &= ~TCL_READABLE;
/*
* Andreas Kupries, April 11, 2003
*
* Some operating systems (Solaris 2.6 and higher (but not
* Solaris 2.5, go figure)) generate READABLE and
* EXCEPTION events when select()'ing [*] on a plain file,
* even if EOF was not yet reached. This is a problem in
* the following situation:
*
* - An extension asks to get both READABLE and EXCEPTION
* events.
* - It reads data into a buffer smaller than the buffer
* used by Tcl itself.
* - It does not process all events in the event queue, but
* only only one, at least in some situations.
*
* In that case we can get into a situation where
*
* - Tcl drops READABLE here, because it has data in its own
* buffers waiting to be read by the extension.
* - A READABLE event is syntesized via timer.
* - The OS still reports the EXCEPTION condition on the file.
* - And the extension gets the EXCPTION event first, and
* handles this as EOF.
*
* End result ==> Premature end of reading from a file.
*
* The concrete example is 'Expect', and its [expect]
* command (and at the C-level, deep in the bowels of
* Expect, 'exp_get_next_event'. See marker 'SunOS' for
* commentary in that function too).
*
* [*] As the Tcl notifier does. See also for marker
* 'SunOS' in file 'exp_event.c' of Expect.
*
* Our solution here is to drop the interest in the
* EXCEPTION events too. This compiles on all platforms,
* and also passes the testsuite on all of them.
*/
mask &= ~TCL_EXCEPTION;
if (!statePtr->timer) {
statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
(ClientData) chanPtr);
}
}
}
(chanPtr->typePtr->watchProc)(chanPtr->instanceData, mask);
|
| ︙ | ︙ | |||
6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 |
* Restart the timer in case a channel handler reenters the
* event loop before UpdateInterest gets called by Tcl_NotifyChannel.
*/
statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
(ClientData) chanPtr);
/* Set the TIMER flag to notify the higher levels that the
* driver might have no data for us. We do this only if we are
* in non-blocking mode and the driver has no BlockModeProc
* because only then we really don't know if the driver will
* block or not. A similar test is done in "PeekAhead".
*/
if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) {
statePtr->flags |= CHANNEL_TIMER_FEV;
}
Tcl_Preserve((ClientData) statePtr);
Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE);
statePtr->flags &= ~CHANNEL_TIMER_FEV;
Tcl_Release((ClientData) statePtr);
} else {
statePtr->timer = NULL;
UpdateInterest(chanPtr);
}
}
| > > > > > > | 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 |
* Restart the timer in case a channel handler reenters the
* event loop before UpdateInterest gets called by Tcl_NotifyChannel.
*/
statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc,
(ClientData) chanPtr);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
/* Set the TIMER flag to notify the higher levels that the
* driver might have no data for us. We do this only if we are
* in non-blocking mode and the driver has no BlockModeProc
* because only then we really don't know if the driver will
* block or not. A similar test is done in "PeekAhead".
*/
if ((statePtr->flags & CHANNEL_NONBLOCKING) &&
(Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL)) {
statePtr->flags |= CHANNEL_TIMER_FEV;
}
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
Tcl_Preserve((ClientData) statePtr);
Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
statePtr->flags &= ~CHANNEL_TIMER_FEV;
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
Tcl_Release((ClientData) statePtr);
} else {
statePtr->timer = NULL;
UpdateInterest(chanPtr);
}
}
|
| ︙ | ︙ | |||
7401 7402 7403 7404 7405 7406 7407 |
CopyState *csPtr;
int nonBlocking = (cmdPtr) ? CHANNEL_NONBLOCKING : 0;
inStatePtr = inPtr->state;
outStatePtr = outPtr->state;
if (inStatePtr->csPtr) {
| > | | > > | | > | 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 |
CopyState *csPtr;
int nonBlocking = (cmdPtr) ? CHANNEL_NONBLOCKING : 0;
inStatePtr = inPtr->state;
outStatePtr = outPtr->state;
if (inStatePtr->csPtr) {
if (interp) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
Tcl_GetChannelName(inChan), "\" is busy", NULL);
}
return TCL_ERROR;
}
if (outStatePtr->csPtr) {
if (interp) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
Tcl_GetChannelName(outChan), "\" is busy", NULL);
}
return TCL_ERROR;
}
readFlags = inStatePtr->flags;
writeFlags = outStatePtr->flags;
/*
|
| ︙ | ︙ | |||
7709 7710 7711 7712 7713 7714 7715 |
/*
* Make the callback or return the number of bytes transferred.
* The local total is used because StopCopy frees csPtr.
*/
total = csPtr->total;
| | | 7990 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 |
/*
* Make the callback or return the number of bytes transferred.
* The local total is used because StopCopy frees csPtr.
*/
total = csPtr->total;
if (cmdPtr && interp) {
/*
* Get a private copy of the command so we can mutate it
* by adding arguments. Note that StopCopy frees our saved
* reference to the original command obj.
*/
cmdPtr = Tcl_DuplicateObj(cmdPtr);
|
| ︙ | ︙ | |||
7733 7734 7735 7736 7737 7738 7739 |
Tcl_BackgroundError(interp);
result = TCL_ERROR;
}
Tcl_DecrRefCount(cmdPtr);
Tcl_Release((ClientData) interp);
} else {
StopCopy(csPtr);
| > | | | | | | > | 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 8032 8033 8034 8035 |
Tcl_BackgroundError(interp);
result = TCL_ERROR;
}
Tcl_DecrRefCount(cmdPtr);
Tcl_Release((ClientData) interp);
} else {
StopCopy(csPtr);
if (interp) {
if (errObj) {
Tcl_SetObjResult(interp, errObj);
result = TCL_ERROR;
} else {
Tcl_ResetResult(interp);
Tcl_SetIntObj(Tcl_GetObjResult(interp), total);
}
}
}
return result;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 |
Tcl_ChannelVersion(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) {
return TCL_CHANNEL_VERSION_2;
} else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) {
return TCL_CHANNEL_VERSION_3;
} else {
/*
* In <v2 channel versions, the version field is occupied
* by the Tcl_DriverBlockModeProc
*/
return TCL_CHANNEL_VERSION_1;
}
| > > | 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 |
Tcl_ChannelVersion(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
if (chanTypePtr->version == TCL_CHANNEL_VERSION_2) {
return TCL_CHANNEL_VERSION_2;
} else if (chanTypePtr->version == TCL_CHANNEL_VERSION_3) {
return TCL_CHANNEL_VERSION_3;
} else if (chanTypePtr->version == TCL_CHANNEL_VERSION_4) {
return TCL_CHANNEL_VERSION_4;
} else {
/*
* In <v2 channel versions, the version field is occupied
* by the Tcl_DriverBlockModeProc
*/
return TCL_CHANNEL_VERSION_1;
}
|
| ︙ | ︙ | |||
9109 9110 9111 9112 9113 9114 9115 |
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) {
return chanTypePtr->wideSeekProc;
} else {
return NULL;
}
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 9394 9395 9396 9397 9398 9399 9400 9401 9402 9403 9404 9405 9406 9407 9408 9409 9410 9411 9412 9413 9414 9415 9416 9417 9418 9419 9420 9421 9422 9423 9424 9425 9426 9427 9428 9429 9430 9431 9432 9433 9434 9435 9436 9437 9438 9439 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 9457 9458 9459 9460 9461 9462 9463 9464 9465 9466 9467 |
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_3)) {
return chanTypePtr->wideSeekProc;
} else {
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelThreadActionProc --
*
* Return the Tcl_DriverThreadActionProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverThreadActionProc *
Tcl_ChannelThreadActionProc(chanTypePtr)
Tcl_ChannelType *chanTypePtr; /* Pointer to channel type. */
{
if (HaveVersion(chanTypePtr, TCL_CHANNEL_VERSION_4)) {
return chanTypePtr->threadActionProc;
} else {
return NULL;
}
}
#if 0
/* For future debugging work, a simple function to print the flags of
* a channel in semi-readable form.
*/
static int
DumpFlags (str, flags)
char* str;
int flags;
{
char buf [20];
int i = 0;
if (flags & TCL_READABLE) {buf[i] = 'r';} else {buf [i]='_';}; i++;
if (flags & TCL_WRITABLE) {buf[i] = 'w';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_NONBLOCKING) {buf[i] = 'n';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_LINEBUFFERED) {buf[i] = 'l';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_UNBUFFERED) {buf[i] = 'u';} else {buf [i]='_';}; i++;
if (flags & BUFFER_READY) {buf[i] = 'R';} else {buf [i]='_';}; i++;
if (flags & BG_FLUSH_SCHEDULED) {buf[i] = 'F';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_CLOSED) {buf[i] = 'c';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_EOF) {buf[i] = 'E';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_STICKY_EOF) {buf[i] = 'S';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_BLOCKED) {buf[i] = 'B';} else {buf [i]='_';}; i++;
if (flags & INPUT_SAW_CR) {buf[i] = '/';} else {buf [i]='_';}; i++;
if (flags & INPUT_NEED_NL) {buf[i] = '*';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_DEAD) {buf[i] = 'D';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_RAW_MODE) {buf[i] = 'R';} else {buf [i]='_';}; i++;
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
if (flags & CHANNEL_TIMER_FEV) {buf[i] = 'T';} else {buf [i]='_';}; i++;
if (flags & CHANNEL_HAS_MORE_DATA) {buf[i] = 'H';} else {buf [i]='_';}; i++;
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
if (flags & CHANNEL_INCLOSE) {buf[i] = 'x';} else {buf [i]='_';}; i++;
buf [i] ='\0';
fprintf (stderr,"%s: %s\n", str, buf); fflush(stderr);
return 0;
}
#endif
|
Changes to generic/tclIO.h.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclIO.h -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * * Copyright (c) 1998-2000 Ajuba Solutions * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclIO.h -- * * This file provides the generic portions (those that are the same on * all platforms and for all channel types) of Tcl's IO facilities. * * Copyright (c) 1998-2000 Ajuba Solutions * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIO.h,v 1.5.4.2 2004/07/15 20:46:19 andreas_kupries Exp $ */ /* * Make sure that both EAGAIN and EWOULDBLOCK are defined. This does not * compile on systems where neither is defined. We want both defined so * that we can test safely for both. In the code we still have to test for * both because there may be systems on which both are defined and have |
| ︙ | ︙ | |||
292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 | * get a complete line or when read * fails to get a complete character. * When set, file events will not be * delivered for buffered data until * the state of the channel changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ #define CHANNEL_TIMER_FEV (1<<17) /* When set the event we are * notified by is a fileevent * generated by a timer. We * don't know if the driver * has more data and should * not try to read from it. If * the system needs more than * is in the buffers out read * routines will simulate a * short read (0 characters * read) */ /* * For each channel handler registered in a call to Tcl_CreateChannelHandler, * there is one record of the following type. All of records for a specific * channel are chained together in a singly linked list which is stored in * the channel structure. */ | > > > > > > > > > > > > > > > > > > > > > > > > > | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 | * get a complete line or when read * fails to get a complete character. * When set, file events will not be * delivered for buffered data until * the state of the channel changes. */ #define CHANNEL_RAW_MODE (1<<16) /* When set, notes that the Raw API is * being used. */ #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING #define CHANNEL_TIMER_FEV (1<<17) /* When set the event we are * notified by is a fileevent * generated by a timer. We * don't know if the driver * has more data and should * not try to read from it. If * the system needs more than * is in the buffers out read * routines will simulate a * short read (0 characters * read) */ #define CHANNEL_HAS_MORE_DATA (1<<18) /* Set by NotifyChannel for a * channel if and only if the * channel is configured * non-blocking, the driver * for said channel has no * blockmodeproc, and data has * arrived for reading at the * OS level). A GetInput will * pass reading from the * driver if the channel is * non-blocking, without * blockmode proc and the flag * has not been set. A read * will be performed if the * flag is set. This will * reset the flag as well. */ #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ #define CHANNEL_INCLOSE (1<<19) /* Channel is currently being * closed. Its structures are * still live and usable, but * it may not be closed again * from within the close handler. */ /* * For each channel handler registered in a call to Tcl_CreateChannelHandler, * there is one record of the following type. All of records for a specific * channel are chained together in a singly linked list which is stored in * the channel structure. */ |
| ︙ | ︙ |
Changes to generic/tclIOCmd.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclIOCmd.c -- * * Contains the definitions of most of the Tcl commands relating to IO. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclIOCmd.c -- * * Contains the definitions of most of the Tcl commands relating to IO. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIOCmd.c,v 1.15.2.2 2004/07/16 22:38:37 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * Callback structure for accept callback in a TCP server. |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | * or documented. */ char *arg; int length; arg = Tcl_GetStringFromObj(objv[3], &length); | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
* or documented.
*/
char *arg;
int length;
arg = Tcl_GetStringFromObj(objv[3], &length);
if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) {
Tcl_AppendResult(interp, "bad argument \"", arg,
"\": should be \"nonewline\"",
(char *) NULL);
return TCL_ERROR;
}
channelId = Tcl_GetString(objv[1]);
string = objv[2];
|
| ︙ | ︙ | |||
1511 1512 1513 1514 1515 1516 1517 |
arg = Tcl_GetString(objv[1]);
inChan = Tcl_GetChannel(interp, arg, &mode);
if (inChan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
| | | | 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 |
arg = Tcl_GetString(objv[1]);
inChan = Tcl_GetChannel(interp, arg, &mode);
if (inChan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
arg,
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
arg = Tcl_GetString(objv[2]);
outChan = Tcl_GetChannel(interp, arg, &mode);
if (outChan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
arg,
"\" wasn't opened for writing", (char *) NULL);
return TCL_ERROR;
}
toRead = -1;
cmdPtr = NULL;
for (i = 3; i < objc; i += 2) {
|
| ︙ | ︙ |
Changes to generic/tclIOGT.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclIOGT.c -- * * Implements a generic transformation exposing the underlying API * at the script level. Contributed by Andreas Kupries. * * Copyright (c) 2000 Ajuba Solutions * Copyright (c) 1999-2000 Andreas Kupries (a.kupries@westend.com) * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclIOGT.c -- * * Implements a generic transformation exposing the underlying API * at the script level. Contributed by Andreas Kupries. * * Copyright (c) 2000 Ajuba Solutions * Copyright (c) 1999-2000 Andreas Kupries (a.kupries@westend.com) * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * CVS: $Id: tclIOGT.c,v 1.7.2.2 2006/08/30 17:24:07 hobbs Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclIO.h" |
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
/*
* This structure describes the channel type structure for tcl based
* transformations.
*/
static Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
| | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
/*
* This structure describes the channel type structure for tcl based
* transformations.
*/
static Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
TCL_CHANNEL_VERSION_3,
TransformCloseProc, /* Close proc. */
TransformInputProc, /* Input proc. */
TransformOutputProc, /* Output proc. */
TransformSeekProc, /* Seek proc. */
TransformSetOptionProc, /* Set option proc. */
TransformGetOptionProc, /* Get option proc. */
TransformWatchProc, /* Initialize notifier. */
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 |
* Step 2, execute the command at the global level of the interpreter
* used to create the transformation. Destroy the command afterward.
* If an error occured and the current interpreter is defined and not
* equal to the interpreter for the callback, then copy the error
* message into current interpreter. Don't copy if in preservation mode.
*/
| | | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 |
* Step 2, execute the command at the global level of the interpreter
* used to create the transformation. Destroy the command afterward.
* If an error occured and the current interpreter is defined and not
* equal to the interpreter for the callback, then copy the error
* message into current interpreter. Don't copy if in preservation mode.
*/
res = Tcl_EvalObjEx(dataPtr->interp, command, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount (command);
command = (Tcl_Obj*) NULL;
if ((res != TCL_OK) && (interp != NO_INTERP) &&
(dataPtr->interp != interp) && !preserve) {
Tcl_SetObjResult(interp, Tcl_GetObjResult(dataPtr->interp));
return res;
|
| ︙ | ︙ |
Changes to generic/tclIOUtil.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | > > > | > > > > > > > > > > > > > > > > > > | > | > > > | | | | > > | | | > | | > | > | > > > > | | < > > > | > > > < < > | < < | | | > > > | > > > | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
*
* Copyright (c) 1991-1994 The Regents of the University of California.
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.34 2007/02/19 23:49:05 hobbs Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#ifdef MAC_TCL
#include "tclMacInt.h"
#endif
#ifdef __WIN32__
/* for tclWinProcs->useWide */
#include "tclWinInt.h"
#endif
/*
* struct FilesystemRecord --
*
* A filesystem record is used to keep track of each
* filesystem currently registered with the core,
* in a linked list. Pointers to these structures
* are also kept by each "path" Tcl_Obj, and we must
* retain a refCount on the number of such references.
*/
typedef struct FilesystemRecord {
ClientData clientData; /* Client specific data for the new
* filesystem (can be NULL) */
Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch
* table. */
int fileRefCount; /* How many Tcl_Obj's use this
* filesystem. */
struct FilesystemRecord *nextPtr;
/* The next filesystem registered
* to Tcl, or NULL if no more. */
struct FilesystemRecord *prevPtr;
/* The previous filesystem registered
* to Tcl, or NULL if no more. */
} FilesystemRecord;
/*
* The internal TclFS API provides routines for handling and
* manipulating paths efficiently, taking direct advantage of
* the "path" Tcl_Obj type.
*
* These functions are not exported at all at present.
*/
int TclFSCwdPointerEquals _ANSI_ARGS_((Tcl_Obj* objPtr));
int TclFSMakePathFromNormalized _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, ClientData clientData));
int TclFSNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int startAt, ClientData *clientDataPtr));
Tcl_Obj* TclFSMakePathRelative _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_Obj *cwdPtr));
Tcl_Obj* TclFSInternalToNormalized _ANSI_ARGS_((
Tcl_Filesystem *fromFilesystem, ClientData clientData,
FilesystemRecord **fsRecPtrPtr));
int TclFSEnsureEpochOk _ANSI_ARGS_((Tcl_Obj* pathObjPtr,
Tcl_Filesystem **fsPtrPtr));
void TclFSSetPathDetails _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
FilesystemRecord *fsRecPtr, ClientData clientData));
/*
* Private variables for use in this file
*/
extern Tcl_Filesystem tclNativeFilesystem;
extern int theFilesystemEpoch;
/*
* Private functions for use in this file
*/
static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr));
static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
static Tcl_FSPathInFilesystemProc NativePathInFilesystem;
static Tcl_Obj* TclFSNormalizeAbsolutePath
_ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr,
ClientData *clientDataPtr));
/*
* Prototypes for procedures defined later in this file.
*/
static FilesystemRecord* FsGetFirstFilesystem(void);
static void FsThrExitProc(ClientData cd);
static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr,
CONST char *pattern));
static Tcl_Obj* FsAddMountsToGlobResult _ANSI_ARGS_((Tcl_Obj *result,
Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types));
#ifdef TCL_THREADS
static void FsRecacheFilesystemList(void);
#endif
/*
* These form part of the native filesystem support. They are needed
* here because we have a few native filesystem functions (which are
* the same for mac/win/unix) in this file. There is no need to place
* them in tclInt.h, because they are not (and should not be) used
* anywhere else.
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
ret = Tcl_FSStat(pathPtr, &buf);
Tcl_DecrRefCount(pathPtr);
if (ret != -1) {
#ifndef TCL_WIDE_INT_IS_LONG
# define OUT_OF_RANGE(x) \
(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
/*
* Perform the result-buffer overflow check manually.
*
* Note that ino_t/ino64_t is unsigned...
*/
| > > > > > > > > > > > | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
ret = Tcl_FSStat(pathPtr, &buf);
Tcl_DecrRefCount(pathPtr);
if (ret != -1) {
#ifndef TCL_WIDE_INT_IS_LONG
# define OUT_OF_RANGE(x) \
(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
#if defined(__GNUC__) && __GNUC__ >= 2
/*
* Workaround gcc warning of "comparison is always false due to limited range of
* data type" in this macro by checking max type size, and when necessary ANDing
* with the complement of ULONG_MAX instead of the comparison:
*/
# define OUT_OF_URANGE(x) \
((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \
(((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))
#else
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
#endif
/*
* Perform the result-buffer overflow check manually.
*
* Note that ino_t/ino64_t is unsigned...
*/
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | static AccessProc *accessProcList = NULL; static OpenFileChannelProc *openFileChannelProcList = NULL; TCL_DECLARE_MUTEX(obsoleteFsHookMutex) #endif /* USE_OBSOLETE_FS_HOOKS */ | < < < < < < < < < < < < < < < < < < < < < < | 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 | static AccessProc *accessProcList = NULL; static OpenFileChannelProc *openFileChannelProcList = NULL; TCL_DECLARE_MUTEX(obsoleteFsHookMutex) #endif /* USE_OBSOLETE_FS_HOOKS */ /* * Declare the native filesystem support. These functions should * be considered private to Tcl, and should really not be called * directly by any code other than this file (i.e. neither by * Tcl's core nor by extensions). Similarly, the old string-based * Tclp... native filesystem functions should not be called. * * The correct API to use now is the Tcl_FS... set of functions, * which ensure correct and complete virtual filesystem support. * * We cannot make all of these static, since some of them * are implemented in the platform-specific directories. */ static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; static Tcl_FSCreateInternalRepProc NativeCreateNativeRep; static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; /* * The only reason these functions are not static is that they |
| ︙ | ︙ | |||
379 380 381 382 383 384 385 | * Define the native filesystem dispatch table. If necessary, it * is ok to make this non-static, but it should only be accessed * by the functions actually listed within it (or perhaps other * helper functions of them). Anything which is not part of this * 'native filesystem implementation' should not be delving inside * here! */ | | | | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 |
* Define the native filesystem dispatch table. If necessary, it
* is ok to make this non-static, but it should only be accessed
* by the functions actually listed within it (or perhaps other
* helper functions of them). Anything which is not part of this
* 'native filesystem implementation' should not be delving inside
* here!
*/
Tcl_Filesystem tclNativeFilesystem = {
"native",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
&NativePathInFilesystem,
&TclNativeDupInternalRep,
&NativeFreeInternalRep,
&TclpNativeToNormalized,
&NativeCreateNativeRep,
&TclpObjNormalizePath,
&TclpFilesystemPathType,
&NativeFilesystemSeparator,
&TclpObjStat,
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 440 |
static FilesystemRecord nativeFilesystemRecord = {
NULL,
&tclNativeFilesystem,
1,
NULL
};
/*
| < < < < < > > | | > > < < < < < < < < < < < < < < < | | | | | | > > > > > > < < | < < < < < | < < < | < < < < < < < < < < | < < < > | < < | < < < < < < | < | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
static FilesystemRecord nativeFilesystemRecord = {
NULL,
&tclNativeFilesystem,
1,
NULL
};
/*
* This is incremented each time we modify the linked list of
* filesystems. Any time it changes, all cached filesystem
* representations are suspect and must be freed.
* For multithreading builds, change of the filesystem epoch
* will trigger cache cleanup in all threads.
*/
int theFilesystemEpoch = 0;
/*
* Stores the linked list of filesystems. A 1:1 copy of this
* list is also maintained in the TSD for each thread. This
* is to avoid synchronization issues.
*/
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)
/*
* Used to implement Tcl_FSGetCwd in a file-system independent way.
*/
static Tcl_Obj* cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
TCL_DECLARE_MUTEX(cwdMutex)
/*
* This structure holds per-thread private copies of
* some global data. This way we avoid most of the
* synchronization calls which boosts performance, at
* cost of having to update this information each
* time the corresponding epoch counter changes.
*
*/
typedef struct ThreadSpecificData {
int initialized;
int cwdPathEpoch;
int filesystemEpoch;
Tcl_Obj *cwdPathPtr;
FilesystemRecord *filesystemList;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Declare fallback support function and
* information for Tcl_FSLoadFile
*/
static Tcl_FSUnloadFileProc FSUnloadTempFile;
/*
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 |
Tcl_Obj *divertedFile;
Tcl_Filesystem *divertedFilesystem;
ClientData divertedFileNativeRep;
} FsDivertLoad;
/* Now move on to the basic filesystem implementation */
| > > > | > > > > > > > > > > > > > > > > > > > > | | > > > | | | > > > > > > > > | > > > > | | > > > > > | > > | > | | > | > > > > > > > | | > > > > > | > | > > > > > > > > > > > > > > | > > | > > > > > > > > > | | > > > > > > > > | > > | > > > > | > > > > > > > | > > > | > > > | > > > > > > > > | > > > > > > > > > > | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
Tcl_Obj *divertedFile;
Tcl_Filesystem *divertedFilesystem;
ClientData divertedFileNativeRep;
} FsDivertLoad;
/* Now move on to the basic filesystem implementation */
static void
FsThrExitProc(cd)
ClientData cd;
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
/* Trash the cwd copy */
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
tsdPtr->cwdPathPtr = NULL;
}
/* Trash the filesystems cache */
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
if (--fsRecPtr->fileRefCount <= 0) {
ckfree((char *)fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
tsdPtr->initialized = 0;
}
int
TclFSCwdPointerEquals(objPtr)
Tcl_Obj* objPtr;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&cwdMutex);
if (tsdPtr->cwdPathPtr == NULL) {
if (cwdPathPtr == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
tsdPtr->cwdPathEpoch = cwdPathEpoch;
} else if (tsdPtr->cwdPathEpoch != cwdPathEpoch) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
if (cwdPathPtr == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
}
Tcl_MutexUnlock(&cwdMutex);
if (tsdPtr->initialized == 0) {
Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
tsdPtr->initialized = 1;
}
return (tsdPtr->cwdPathPtr == objPtr);
}
#ifdef TCL_THREADS
static void
FsRecacheFilesystemList(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL;
/* Trash the current cache */
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
if (--fsRecPtr->fileRefCount <= 0) {
ckfree((char *)fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = NULL;
/*
* Code below operates on shared data. We
* are already called under mutex lock so
* we can safely proceed.
*/
/* Locate tail of the global filesystem list */
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr;
fsRecPtr = fsRecPtr->nextPtr;
}
/* Refill the cache honouring the order */
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
tmpFsRecPtr->prevPtr = NULL;
if (tsdPtr->filesystemList) {
tsdPtr->filesystemList->prevPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = tmpFsRecPtr;
fsRecPtr = fsRecPtr->prevPtr;
}
/* Make sure the above gets released on thread exit */
if (tsdPtr->initialized == 0) {
Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
tsdPtr->initialized = 1;
}
}
#endif
static FilesystemRecord *
FsGetFirstFilesystem(void) {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FilesystemRecord *fsRecPtr;
#ifndef TCL_THREADS
tsdPtr->filesystemEpoch = theFilesystemEpoch;
fsRecPtr = filesystemList;
#else
Tcl_MutexLock(&filesystemMutex);
if (tsdPtr->filesystemList == NULL
|| (tsdPtr->filesystemEpoch != theFilesystemEpoch)) {
FsRecacheFilesystemList();
tsdPtr->filesystemEpoch = theFilesystemEpoch;
}
Tcl_MutexUnlock(&filesystemMutex);
fsRecPtr = tsdPtr->filesystemList;
#endif
return fsRecPtr;
}
static void
FsUpdateCwd(cwdObj)
Tcl_Obj *cwdObj;
{
int len;
char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (cwdObj != NULL) {
str = Tcl_GetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
}
if (cwdObj == NULL) {
cwdPathPtr = NULL;
} else {
/* This MUST be stored as string object! */
cwdPathPtr = Tcl_NewStringObj(str, len);
Tcl_IncrRefCount(cwdPathPtr);
}
cwdPathEpoch++;
tsdPtr->cwdPathEpoch = cwdPathEpoch;
Tcl_MutexUnlock(&cwdMutex);
if (tsdPtr->cwdPathPtr) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
}
if (cwdObj == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeFilesystem --
*
|
| ︙ | ︙ | |||
602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeFilesystem()
{
/*
* Assumption that only one thread is active now. Otherwise
* we would need to put various mutexes around this code.
*/
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
cwdPathPtr = NULL;
}
/*
* Remove all filesystems, freeing any allocated memory
* that is no longer needed
*/
| > > > > | > | | < < < < < < < | | > > | | > | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeFilesystem()
{
FilesystemRecord *fsRecPtr;
/*
* Assumption that only one thread is active now. Otherwise
* we would need to put various mutexes around this code.
*/
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
cwdPathPtr = NULL;
cwdPathEpoch = 0;
}
/*
* Remove all filesystems, freeing any allocated memory
* that is no longer needed
*/
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
if (fsRecPtr->fileRefCount <= 0) {
/* The native filesystem is static, so we don't free it */
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
ckfree((char *)fsRecPtr);
}
}
fsRecPtr = tmpFsRecPtr;
}
filesystemList = NULL;
/*
* Now filesystemList is NULL. This means that any attempt
* to use the filesystem is likely to fail.
*/
statProcList = NULL;
accessProcList = NULL;
openFileChannelProcList = NULL;
#ifdef __WIN32__
TclWinEncodingsCleanup();
#endif
}
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 672 673 674 675 676 677 |
*----------------------------------------------------------------------
*/
void
TclResetFilesystem()
{
filesystemList = &nativeFilesystemRecord;
/*
* Note, at this point, I believe nativeFilesystemRecord ->
* fileRefCount should equal 1 and if not, we should try to track
* down the cause.
*/
| > < < < < < | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 |
*----------------------------------------------------------------------
*/
void
TclResetFilesystem()
{
filesystemList = &nativeFilesystemRecord;
/*
* Note, at this point, I believe nativeFilesystemRecord ->
* fileRefCount should equal 1 and if not, we should try to track
* down the cause.
*/
#ifdef __WIN32__
/*
* Cleans up the win32 API filesystem proc lookup table. This must
* happen very late in finalization so that deleting of copied
* dlls can occur.
*/
TclWinResetInterfaces();
|
| ︙ | ︙ | |||
752 753 754 755 756 757 758 |
* cached representations calculated by existing iterators are
* going to have to be thrown away anyway.
*
* However, since registering and unregistering filesystems is
* a very rare action, this is not a very important point.
*/
Tcl_MutexLock(&filesystemMutex);
| | | | | > < < > | 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 |
* cached representations calculated by existing iterators are
* going to have to be thrown away anyway.
*
* However, since registering and unregistering filesystems is
* a very rare action, this is not a very important point.
*/
Tcl_MutexLock(&filesystemMutex);
newFilesystemPtr->nextPtr = filesystemList;
newFilesystemPtr->prevPtr = NULL;
if (filesystemList) {
filesystemList->prevPtr = newFilesystemPtr;
}
filesystemList = newFilesystemPtr;
/*
* Increment the filesystem epoch counter, since existing paths
* might conceivably now belong to different filesystems.
*/
theFilesystemEpoch++;
Tcl_MutexUnlock(&filesystemMutex);
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 |
*/
int
Tcl_FSUnregister(fsPtr)
Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
| | < < < < < | < > | | | | > > | > | | | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
*/
int
Tcl_FSUnregister(fsPtr)
Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;
Tcl_MutexLock(&filesystemMutex);
/*
* Traverse the 'filesystemList' looking for the particular node
* whose 'fsPtr' member matches 'fsPtr' and remove that one from
* the list. Ensure that the "default" node cannot be removed.
*/
fsRecPtr = filesystemList;
while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) {
if (fsRecPtr->fsPtr == fsPtr) {
if (fsRecPtr->prevPtr) {
fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
} else {
filesystemList = fsRecPtr->nextPtr;
}
if (fsRecPtr->nextPtr) {
fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr;
}
/*
* Increment the filesystem epoch counter, since existing
* paths might conceivably now belong to different
* filesystems. This should also ensure that paths which
* have cached the filesystem which is about to be deleted
* do not reference that filesystem (which would of course
* lead to memory exceptions).
*/
theFilesystemEpoch++;
fsRecPtr->fileRefCount--;
if (fsRecPtr->fileRefCount <= 0) {
ckfree((char *)fsRecPtr);
}
retVal = TCL_OK;
} else {
fsRecPtr = fsRecPtr->nextPtr;
}
}
Tcl_MutexUnlock(&filesystemMutex);
return (retVal);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSMatchInDirectory --
*
* This routine is used by the globbing code to search a directory
* for all files which match a given pattern. The appropriate
* function for the filesystem to which pathPtr belongs will be
* called. If pathPtr does not belong to any filesystem and if it
* is NULL or the empty string, then we assume the pattern is to be
* matched in the current working directory. To avoid each
* filesystem's Tcl_FSMatchInDirectoryProc having to deal with this
* issue, we create a pathPtr on the fly (equal to the cwd), and
* then remove it from the results returned. This makes filesystems
* easy to write, since they can assume the pathPtr passed to them
* is an ordinary path. In fact this means we could remove such
* special case handling from Tcl's native filesystems.
*
* If 'pattern' is NULL, then pathPtr is assumed to be a fully
* specified path of a single file/directory which must be
* checked for existence and correct type.
*
* Results:
*
* The return value is a standard Tcl result indicating whether an
* error occurred in globbing. Error messages are placed in
* interp, but good results are placed in the resultPtr given.
*
* Recursive searches, e.g.
*
* glob -dir $dir -join * pkgIndex.tcl
*
* which must recurse through each directory matching '*' are
* handled internally by Tcl, by passing specific flags in a
* modified 'types' parameter. This means the actual filesystem
* only ever sees patterns which match in a single directory.
*
* Side effects:
* The interpreter may have an error message inserted into it.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
Tcl_Interp *interp; /* Interpreter to receive error messages. */
Tcl_Obj *result; /* List object to receive results. */
Tcl_Obj *pathPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
* May be NULL. In particular the directory
* flag is very important. */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
if (proc != NULL) {
int ret = (*proc)(interp, result, pathPtr, pattern, types);
if (ret == TCL_OK && pattern != NULL) {
result = FsAddMountsToGlobResult(result, pathPtr,
pattern, types);
}
return ret;
}
} else {
Tcl_Obj* cwd;
int ret = -1;
if (pathPtr != NULL) {
int len;
Tcl_GetStringFromObj(pathPtr,&len);
if (len != 0) {
/*
* We have no idea how to match files in a directory
* which belongs to no known filesystem
*/
Tcl_SetErrno(ENOENT);
return -1;
}
}
/*
* We have an empty or NULL path. This is defined to mean we
* must search for files within the current 'cwd'. We
* therefore use that, but then since the proc we call will
* return results which include the cwd we must then trim it
* off the front of each path in the result. We choose to deal
* with this here (in the generic code), since if we don't,
* every single filesystem's implementation of
* Tcl_FSMatchInDirectory will have to deal with it for us.
*/
cwd = Tcl_FSGetCwd(NULL);
if (cwd == NULL) {
if (interp != NULL) {
Tcl_SetResult(interp, "glob couldn't determine "
"the current working directory", TCL_STATIC);
}
return TCL_ERROR;
}
fsPtr = Tcl_FSGetFileSystemForPath(cwd);
if (fsPtr != NULL) {
Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
if (proc != NULL) {
Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL);
Tcl_IncrRefCount(tmpResultPtr);
ret = (*proc)(interp, tmpResultPtr, cwd, pattern, types);
if (ret == TCL_OK) {
int resLength;
tmpResultPtr = FsAddMountsToGlobResult(tmpResultPtr, cwd,
pattern, types);
ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength);
if (ret == TCL_OK) {
int i;
for (i = 0; i < resLength; i++) {
Tcl_Obj *elt;
Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt);
Tcl_ListObjAppendElement(interp, result,
TclFSMakePathRelative(interp, elt, cwd));
}
}
}
Tcl_DecrRefCount(tmpResultPtr);
}
}
Tcl_DecrRefCount(cwd);
return ret;
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* FsAddMountsToGlobResult --
*
* This routine is used by the globbing code to take the results
* of a directory listing and add any mounted paths to that
* listing. This is required so that simple things like
* 'glob *' merge mounts and listings correctly.
*
* Results:
*
* The passed in 'result' may be modified (in place, if
* necessary), and the correct list is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj*
FsAddMountsToGlobResult(result, pathPtr, pattern, types)
Tcl_Obj *result; /* The current list of matching paths */
Tcl_Obj *pathPtr; /* The directory in question */
CONST char *pattern;
Tcl_GlobTypeData *types;
{
int mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);
if (mounts == NULL) return result;
if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
goto endOfMounts;
}
if (Tcl_ListObjLength(NULL, result, &gLength) != TCL_OK) {
goto endOfMounts;
}
for (i = 0; i < mLength; i++) {
Tcl_Obj *mElt;
int j;
int found = 0;
Tcl_ListObjIndex(NULL, mounts, i, &mElt);
for (j = 0; j < gLength; j++) {
Tcl_Obj *gElt;
Tcl_ListObjIndex(NULL, result, j, &gElt);
if (Tcl_FSEqualPaths(mElt, gElt)) {
found = 1;
if (!dir) {
/* We don't want to list this */
if (Tcl_IsShared(result)) {
Tcl_Obj *newList;
newList = Tcl_DuplicateObj(result);
Tcl_DecrRefCount(result);
result = newList;
}
Tcl_ListObjReplace(NULL, result, j, 1, 0, NULL);
gLength--;
}
/* Break out of for loop */
break;
}
}
if (!found && dir) {
if (Tcl_IsShared(result)) {
Tcl_Obj *newList;
newList = Tcl_DuplicateObj(result);
Tcl_DecrRefCount(result);
result = newList;
}
Tcl_ListObjAppendElement(NULL, result, mElt);
/*
* No need to increment gLength, since we
* don't want to compare mounts against
* mounts.
*/
}
}
endOfMounts:
Tcl_DecrRefCount(mounts);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSMountsChanged --
*
* Notify the filesystem that the available mounted filesystems
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 |
*/
ClientData
Tcl_FSData(fsPtr)
Tcl_Filesystem *fsPtr; /* The filesystem record to query. */
{
ClientData retVal = NULL;
| | < | | | | < | | | 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 |
*/
ClientData
Tcl_FSData(fsPtr)
Tcl_Filesystem *fsPtr; /* The filesystem record to query. */
{
ClientData retVal = NULL;
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
/*
* Traverse the 'filesystemList' looking for the particular node
* whose 'fsPtr' member matches 'fsPtr' and remove that one from
* the list. Ensure that the "default" node cannot be removed.
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
if (fsRecPtr->fsPtr == fsPtr) {
retVal = fsRecPtr->clientData;
}
fsRecPtr = fsRecPtr->nextPtr;
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* TclFSNormalizeAbsolutePath --
*
* Description:
* Takes an absolute path specification and computes a 'normalized'
* path from it.
*
* A normalized path is one which has all '../', './' removed.
* Also it is one which is in the 'standard' format for the native
|
| ︙ | ︙ | |||
996 997 998 999 1000 1001 1002 | * Special note: * This code is based on code from Matt Newman and Jean-Claude * Wippler, with additions from Vince Darley and is copyright * those respective authors. * *--------------------------------------------------------------------------- */ | | | > | 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 |
* Special note:
* This code is based on code from Matt Newman and Jean-Claude
* Wippler, with additions from Vince Darley and is copyright
* those respective authors.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj *
TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr)
Tcl_Interp* interp; /* Interpreter to use */
Tcl_Obj *pathPtr; /* Absolute path to normalize */
ClientData *clientDataPtr;
{
int splen = 0, nplen, eltLen, i;
char *eltName;
Tcl_Obj *retVal;
Tcl_Obj *split;
Tcl_Obj *elt;
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 |
Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
}
} else {
nplen++;
}
}
if (nplen > 0) {
retVal = Tcl_FSJoinPath(split, nplen);
/*
* Now we have an absolute path, with no '..', '.' sequences,
* but it still may not be in 'unique' form, depending on the
* platform. For instance, Unix is case-sensitive, so the
* path is ok. Windows is case-insensitive, and also has the
* weird 'longname/shortname' thing (e.g. C:/Program Files/ and
* C:/Progra~1/ are equivalent). MacOS is case-insensitive.
*
* Virtual file systems which may be registered may have
* other criteria for normalizing a path.
*/
Tcl_IncrRefCount(retVal);
| > > | | | > > > | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
}
} else {
nplen++;
}
}
if (nplen > 0) {
ClientData clientData = NULL;
retVal = Tcl_FSJoinPath(split, nplen);
/*
* Now we have an absolute path, with no '..', '.' sequences,
* but it still may not be in 'unique' form, depending on the
* platform. For instance, Unix is case-sensitive, so the
* path is ok. Windows is case-insensitive, and also has the
* weird 'longname/shortname' thing (e.g. C:/Program Files/ and
* C:/Progra~1/ are equivalent). MacOS is case-insensitive.
*
* Virtual file systems which may be registered may have
* other criteria for normalizing a path.
*/
Tcl_IncrRefCount(retVal);
TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData);
/*
* Since we know it is a normalized path, we can
* actually convert this object into an "path" object for
* greater efficiency
*/
TclFSMakePathFromNormalized(interp, retVal, clientData);
if (clientDataPtr != NULL) {
*clientDataPtr = clientData;
}
} else {
/* Init to an empty string */
retVal = Tcl_NewStringObj("",0);
Tcl_IncrRefCount(retVal);
}
/*
* We increment and then decrement the refCount of split to free
|
| ︙ | ︙ | |||
1079 1080 1081 1082 1083 1084 1085 |
/* This has a refCount of 1 for the caller */
return retVal;
}
/*
*---------------------------------------------------------------------------
*
| | | 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 |
/* This has a refCount of 1 for the caller */
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* TclFSNormalizeToUniquePath --
*
* Description:
* Takes a path specification containing no ../, ./ sequences,
* and converts it into a unique path for the given platform.
* On MacOS, Unix, this means the path must be free of
* symbolic links/aliases, and on Windows it means we want the
* long form, with that long form's case-dependence (which gives
|
| ︙ | ︙ | |||
1109 1110 1111 1112 1113 1114 1115 | * * Important assumption: if startAt is non-zero, it must point * to a directory separator that we know exists and is already * normalized (so it is important not to point to the char just * after the separator). *--------------------------------------------------------------------------- */ | | | > | > > | | > > | < | | < | | 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 |
*
* Important assumption: if startAt is non-zero, it must point
* to a directory separator that we know exists and is already
* normalized (so it is important not to point to the char just
* after the separator).
*---------------------------------------------------------------------------
*/
int
TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
Tcl_Interp *interp;
Tcl_Obj *pathPtr;
int startAt;
ClientData *clientDataPtr;
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
/* Ignore this variable */
(void)clientDataPtr;
/*
* Call each of the "normalise path" functions in succession. This is
* a special case, in which if we have a native filesystem handler,
* we call it first. This is because the root of Tcl's filesystem
* is always a native filesystem (i.e. '/' on unix is native).
*/
firstFsRecPtr = FsGetFirstFilesystem();
fsRecPtr = firstFsRecPtr;
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
if (proc != NULL) {
startAt = (*proc)(interp, pathPtr, startAt);
}
break;
}
fsRecPtr = fsRecPtr->nextPtr;
}
fsRecPtr = firstFsRecPtr;
while (fsRecPtr != NULL) {
/* Skip the native system next time through */
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
if (proc != NULL) {
startAt = (*proc)(interp, pathPtr, startAt);
}
/*
* We could add an efficiency check like this:
*
* if (retVal == length-of(pathPtr)) {break;}
*
* but there's not much benefit.
*/
}
fsRecPtr = fsRecPtr->nextPtr;
}
return startAt;
}
/*
*---------------------------------------------------------------------------
*
* TclGetOpenMode --
*
|
| ︙ | ︙ | |||
1224 1225 1226 1227 1228 1229 1230 | case 'r': mode = O_RDONLY; break; case 'w': mode = O_WRONLY|O_CREAT|O_TRUNC; break; case 'a': | > > > > | | 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 |
case 'r':
mode = O_RDONLY;
break;
case 'w':
mode = O_WRONLY|O_CREAT|O_TRUNC;
break;
case 'a':
/* [Bug 680143].
* Added O_APPEND for proper automatic
* seek-to-end-on-write by the OS.
*/
mode = O_WRONLY|O_CREAT|O_APPEND;
*seekFlagPtr = 1;
break;
default:
error:
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"illegal access mode \"", string, "\"",
|
| ︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 |
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
char *string;
Tcl_Channel chan;
Tcl_Obj *objPtr;
| | > | 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 |
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
char *string;
Tcl_Channel chan;
Tcl_Obj *objPtr;
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return TCL_ERROR;
}
result = TCL_ERROR;
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr);
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_AppendResult(interp, "couldn't read file \"",
Tcl_GetString(pathPtr),
"\": ", Tcl_PosixError(interp), (char *) NULL);
goto end;
|
| ︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
string = Tcl_GetStringFromObj(objPtr, &length);
result = Tcl_EvalEx(interp, string, length, 0);
/*
* Now we have to be careful; the script may have changed the
* iPtr->scriptFile value, so we must reset it without
* assuming it still points to 'pathPtr'.
*/
if (iPtr->scriptFile != NULL) {
| > > > > > > | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 |
}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
string = Tcl_GetStringFromObj(objPtr, &length);
#ifdef TCL_TIP280
/* TIP #280 Force the evaluator to open a frame for a sourced
* file. */
iPtr->evalFlags |= TCL_EVAL_FILE;
#endif
result = Tcl_EvalEx(interp, string, length, 0);
/*
* Now we have to be careful; the script may have changed the
* iPtr->scriptFile value, so we must reset it without
* assuming it still points to 'pathPtr'.
*/
if (iPtr->scriptFile != NULL) {
|
| ︙ | ︙ | |||
1521 1522 1523 1524 1525 1526 1527 |
Tcl_Interp *interp; /* Interpreter whose $errorCode variable
* is to be changed. */
{
CONST char *id, *msg;
msg = Tcl_ErrnoMsg(errno);
id = Tcl_ErrnoId();
| > | > | 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 |
Tcl_Interp *interp; /* Interpreter whose $errorCode variable
* is to be changed. */
{
CONST char *id, *msg;
msg = Tcl_ErrnoMsg(errno);
id = Tcl_ErrnoId();
if (interp) {
Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
}
return msg;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSStat --
|
| ︙ | ︙ | |||
1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 |
}
statProcPtr = statProcList;
while ((retVal == -1) && (statProcPtr != NULL)) {
retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
statProcPtr = statProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != -1) {
/*
* Note that EOVERFLOW is not a problem here, and these
* assignments should all be widening (if not identity.)
| > > > | 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 |
}
statProcPtr = statProcList;
while ((retVal == -1) && (statProcPtr != NULL)) {
retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
statProcPtr = statProcPtr->nextPtr;
}
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != -1) {
/*
* Note that EOVERFLOW is not a problem here, and these
* assignments should all be widening (if not identity.)
|
| ︙ | ︙ | |||
1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
}
accessProcPtr = accessProcList;
while ((retVal == -1) && (accessProcPtr != NULL)) {
retVal = (*accessProcPtr->proc)(path, mode);
accessProcPtr = accessProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != -1) {
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
| > > > | 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 |
}
accessProcPtr = accessProcList;
while ((retVal == -1) && (accessProcPtr != NULL)) {
retVal = (*accessProcPtr->proc)(path, mode);
accessProcPtr = accessProcPtr->nextPtr;
}
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != -1) {
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
|
| ︙ | ︙ | |||
1753 1754 1755 1756 1757 1758 1759 |
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
| < < < < < < | < < < < < < < | > > > > > > > > > > > | > | | | | > > > > > > > > > > > > > | 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 |
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
Tcl_Channel retVal = NULL;
/*
* Call each of the "Tcl_OpenFileChannel" functions in succession.
* A non-NULL return value indicates the particular function has
* succeeded.
*/
Tcl_MutexLock(&obsoleteFsHookMutex);
if (openFileChannelProcList != NULL) {
OpenFileChannelProc *openFileChannelProcPtr;
char *path;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr == NULL) {
path = NULL;
} else {
path = Tcl_GetString(transPtr);
}
openFileChannelProcPtr = openFileChannelProcList;
while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
retVal = (*openFileChannelProcPtr->proc)(interp, path,
modeString, permissions);
openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
}
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
if (retVal != NULL) {
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
/*
* We need this just to ensure we return the correct error messages
* under some circumstances.
*/
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return NULL;
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
if (proc != NULL) {
int mode, seekFlag;
mode = TclGetOpenMode(interp, modeString, &seekFlag);
if (mode == -1) {
|
| ︙ | ︙ | |||
1823 1824 1825 1826 1827 1828 1829 |
if (interp != NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 |
if (interp != NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSUtime --
*
* This procedure replaces the library version of utime.
|
| ︙ | ︙ | |||
2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 |
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSChdir --
*
* This function replaces the library version of chdir().
*
* The path is normalized and then passed to the filesystem
* which claims it.
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 |
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSGetCwd --
*
* This function replaces the library version of getcwd().
*
* Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains
* its own record (in a Tcl_Obj) of the cwd, and an attempt
* is made to synchronise this with the cwd's containing filesystem,
* if that filesystem provides a cwdProc (e.g. the native filesystem).
*
* Note that if Tcl's cwd is not in the native filesystem, then of
* course Tcl's cwd and the native cwd are different: extensions
* should therefore ensure they only access the cwd through this
* function to avoid confusion.
*
* If a global cwdPathPtr already exists, it is cached in the thread's
* private data structures and reference to the cached copy is returned,
* subject to a synchronisation attempt in that cwdPathPtr's fs.
*
* Otherwise, the chain of functions that have been "inserted"
* into the filesystem will be called in succession until either a
* value other than NULL is returned, or the entire list is
* visited.
*
* Results:
* The result is a pointer to a Tcl_Obj specifying the current
* directory, or NULL if the current directory could not be
* determined. If NULL is returned, an error message is left in the
* interp's result.
*
* The result already has its refCount incremented for the caller.
* When it is no longer needed, that refCount should be decremented.
*
* Side effects:
* Various objects may be freed and allocated.
*
*----------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSGetCwd(interp)
Tcl_Interp *interp;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (TclFSCwdPointerEquals(NULL)) {
FilesystemRecord *fsRecPtr;
Tcl_Obj *retVal = NULL;
/*
* We've never been called before, try to find a cwd. Call
* each of the "Tcl_GetCwd" function in succession. A non-NULL
* return value indicates the particular function has
* succeeded.
*/
fsRecPtr = FsGetFirstFilesystem();
while ((retVal == NULL) && (fsRecPtr != NULL)) {
Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
if (proc != NULL) {
retVal = (*proc)(interp);
}
fsRecPtr = fsRecPtr->nextPtr;
}
/*
* Now the 'cwd' may NOT be normalized, at least on some
* platforms. For the sake of efficiency, we want a completely
* normalized cwd at all times.
*
* Finally, if retVal is NULL, we do not have a cwd, which
* could be problematic.
*/
if (retVal != NULL) {
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
if (norm != NULL) {
/*
* We found a cwd, which is now in our global storage.
* We must make a copy. Norm already has a refCount of 1.
*
* Threading issue: note that multiple threads at system
* startup could in principle call this procedure
* simultaneously. They will therefore each set the
* cwdPathPtr independently. That behaviour is a bit
* peculiar, but should be fine. Once we have a cwd,
* we'll always be in the 'else' branch below which
* is simpler.
*/
FsUpdateCwd(norm);
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
}
} else {
/*
* We already have a cwd cached, but we want to give the
* filesystem it is in a chance to check whether that cwd
* has changed, or is perhaps no longer accessible. This
* allows an error to be thrown if, say, the permissions on
* that directory have changed.
*/
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);
/*
* If the filesystem couldn't be found, or if no cwd function
* exists for this filesystem, then we simply assume the cached
* cwd is ok. If we do call a cwd, we must watch for errors
* (if the cwd returns NULL). This ensures that, say, on Unix
* if the permissions of the cwd change, 'pwd' does actually
* throw the correct error in Tcl. (This is tested for in the
* test suite on unix).
*/
if (fsPtr != NULL) {
Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
if (proc != NULL) {
Tcl_Obj *retVal = (*proc)(interp);
if (retVal != NULL) {
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
/*
* Check whether cwd has changed from the value
* previously stored in cwdPathPtr. Really 'norm'
* shouldn't be null, but we are careful.
*/
if (norm == NULL) {
/* Do nothing */
} else if (Tcl_FSEqualPaths(tsdPtr->cwdPathPtr, norm)) {
/*
* If the paths were equal, we can be more
* efficient and retain the old path object
* which will probably already be shared. In
* this case we can simply free the normalized
* path we just calculated.
*/
Tcl_DecrRefCount(norm);
} else {
FsUpdateCwd(norm);
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
} else {
/* The 'cwd' function returned an error; reset the cwd */
FsUpdateCwd(NULL);
}
}
}
}
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
return tsdPtr->cwdPathPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSChdir --
*
* This function replaces the library version of chdir().
*
* The path is normalized and then passed to the filesystem
* which claims it.
*
|
| ︙ | ︙ | |||
2463 2464 2465 2466 2467 2468 2469 2470 |
int
Tcl_FSChdir(pathPtr)
Tcl_Obj *pathPtr;
{
Tcl_Filesystem *fsPtr;
int retVal = -1;
if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 |
int
Tcl_FSChdir(pathPtr)
Tcl_Obj *pathPtr;
{
Tcl_Filesystem *fsPtr;
int retVal = -1;
#ifdef WIN32
/*
* This complete hack addresses the bug tested in winFCmd-16.12,
* where having your HOME as "C:" (IOW, a seemingly path relative
* dir) would cause a crash when you cd'd to it and requested 'pwd'.
* The work-around is to force such a dir into an absolute path by
* tacking on '/'.
*
* We check for '~' specifically because that's what Tcl_CdObjCmd
* passes in that triggers the bug. A direct 'cd C:' call will not
* because that gets the volumerelative pwd.
*
* This is not an issue for 8.5 as that has a more elaborate change
* that requires the use of TCL_FILESYSTEM_VERSION_2.
*/
Tcl_Obj *objPtr = NULL;
if (pathPtr->bytes && pathPtr->length == 1 && pathPtr->bytes[0] == '~') {
int len;
char *str;
objPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (objPtr == NULL) {
Tcl_SetErrno(ENOENT);
return -1;
}
Tcl_IncrRefCount(objPtr);
str = Tcl_GetStringFromObj(objPtr, &len);
if (len == 2 && str[1] == ':') {
pathPtr = Tcl_NewStringObj(str, len);
Tcl_AppendToObj(pathPtr, "/", 1);
Tcl_IncrRefCount(pathPtr);
Tcl_DecrRefCount(objPtr);
objPtr = pathPtr;
} else {
Tcl_DecrRefCount(objPtr);
objPtr = NULL;
}
}
#endif
if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
#ifdef WIN32
if (objPtr) { Tcl_DecrRefCount(objPtr); }
#endif
Tcl_SetErrno(ENOENT);
return -1;
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSChdirProc *proc = fsPtr->chdirProc;
if (proc != NULL) {
retVal = (*proc)(pathPtr);
|
| ︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 | * The cwd changed, or an error was thrown. If an error was * thrown, we can just continue (and that will report the error * to the user). If there was no error we must assume that the * cwd was actually changed to the normalized value we * calculated above, and we must therefore cache that * information. */ | | > > > > | < < < < | < < < < < | | < | | | | > > | 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 |
* The cwd changed, or an error was thrown. If an error was
* thrown, we can just continue (and that will report the error
* to the user). If there was no error we must assume that the
* cwd was actually changed to the normalized value we
* calculated above, and we must therefore cache that
* information.
*/
if (retVal == 0) {
/*
* Note that this normalized path may be different to what
* we found above (or at least a different object), if the
* filesystem epoch changed recently. This can actually
* happen with scripted documents very easily. Therefore
* we ask for the normalized path again (the correct value
* will have been cached as a result of the
* Tcl_FSGetFileSystemForPath call above anyway).
*/
Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normDirName == NULL) {
#ifdef WIN32
if (objPtr) { Tcl_DecrRefCount(objPtr); }
#endif
Tcl_SetErrno(ENOENT);
return -1;
}
FsUpdateCwd(normDirName);
}
} else {
Tcl_SetErrno(ENOENT);
}
#ifdef WIN32
if (objPtr) { Tcl_DecrRefCount(objPtr); }
#endif
return (retVal);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSLoadFile --
|
| ︙ | ︙ | |||
2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 |
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
Tcl_AppendResult(interp, "couldn't load library \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
/*
* Get a temporary filename to use, first to
* copy the file into, and then to load.
*/
copyToPtr = TclpTempFileName();
if (copyToPtr == NULL) {
return -1;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 |
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
Tcl_AppendResult(interp, "couldn't load library \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
#ifdef TCL_LOAD_FROM_MEMORY
/*
* The platform supports loading code from memory, so ask for a
* buffer of the appropriate size, read the file into it and
* load the code from the buffer:
*/
do {
int ret, size;
void *buffer;
Tcl_StatBuf statBuf;
Tcl_Channel data;
ret = Tcl_FSStat(pathPtr, &statBuf);
if (ret < 0) {
break;
}
size = (int) statBuf.st_size;
/* Tcl_Read takes an int: check that file size isn't wide */
if (size != (Tcl_WideInt)statBuf.st_size) {
break;
}
data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666);
if (!data) {
break;
}
buffer = TclpLoadMemoryGetBuffer(interp, size);
if (!buffer) {
Tcl_Close(interp, data);
break;
}
Tcl_SetChannelOption(interp, data, "-translation", "binary");
ret = Tcl_Read(data, buffer, size);
Tcl_Close(interp, data);
ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, unloadProcPtr);
if (ret == TCL_OK) {
if (*handlePtr == NULL) {
break;
}
if (sym1 != NULL) {
*proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
}
if (sym2 != NULL) {
*proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
}
return TCL_OK;
}
} while (0);
Tcl_ResetResult(interp);
#endif
/*
* Get a temporary filename to use, first to
* copy the file into, and then to load.
*/
copyToPtr = TclpTempFileName();
if (copyToPtr == NULL) {
return -1;
|
| ︙ | ︙ | |||
2719 2720 2721 2722 2723 2724 2725 |
* need to worry about it disappearing on us.
*/
tvdlPtr->divertedFilesystem = copyFsPtr;
tvdlPtr->divertedFileNativeRep = NULL;
} else {
/* We need the native rep */
tvdlPtr->divertedFileNativeRep =
| | | 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 |
* need to worry about it disappearing on us.
*/
tvdlPtr->divertedFilesystem = copyFsPtr;
tvdlPtr->divertedFileNativeRep = NULL;
} else {
/* We need the native rep */
tvdlPtr->divertedFileNativeRep =
TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr,
copyFsPtr));
/*
* We don't need or want references to the copied
* Tcl_Obj or the filesystem if it is the native
* one.
*/
tvdlPtr->divertedFile = NULL;
|
| ︙ | ︙ | |||
2980 2981 2982 2983 2984 2985 2986 |
/*
* Call each of the "listVolumes" function in succession.
* A non-NULL return value indicates the particular function has
* succeeded. We call all the functions registered, since we want
* a list of all drives from all filesystems.
*/
| | < | | > | < | > | | | | | | > < < | < < < < < < < < < > | < | < > | | | | | < < | < < | < < | | < < | < > | < < | | < | < | < < > > | | | > | 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 |
/*
* Call each of the "listVolumes" function in succession.
* A non-NULL return value indicates the particular function has
* succeeded. We call all the functions registered, since we want
* a list of all drives from all filesystems.
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
if (proc != NULL) {
Tcl_Obj *thisFsVolumes = (*proc)();
if (thisFsVolumes != NULL) {
Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
Tcl_DecrRefCount(thisFsVolumes);
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
return resultPtr;
}
/*
*---------------------------------------------------------------------------
*
* FsListMounts --
*
* List all mounts within the given directory, which match the
* given pattern.
*
* Results:
* The list of mounts, in a list object which has refCount 0, or
* NULL if we didn't even find any filesystems to try to list
* mounts.
*
* Side effects:
* None
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj*
FsListMounts(pathPtr, pattern)
Tcl_Obj *pathPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
{
FilesystemRecord *fsRecPtr;
Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL };
Tcl_Obj *resultPtr = NULL;
/*
* Call each of the "listMounts" functions in succession.
* A non-NULL return value indicates the particular function has
* succeeded. We call all the functions registered, since we want
* a list from each filesystems.
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
Tcl_FSMatchInDirectoryProc *proc =
fsRecPtr->fsPtr->matchInDirectoryProc;
if (proc != NULL) {
if (resultPtr == NULL) {
resultPtr = Tcl_NewObj();
}
(*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly);
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
return resultPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSSplitPath --
*
|
| ︙ | ︙ | |||
3167 3168 3169 3170 3171 3172 3173 |
if (lenPtr != NULL) {
Tcl_ListObjLength(NULL, result, lenPtr);
}
return result;
}
| < < < < < < < < < < < < < < < | < < < < | < < < < < | | < < < < < < < < < < < < < < < < < < | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < | < < < < < < | < < < < < < < | | | < < < < < < < < | < | < < < < < < < | < < < < < | < < | < < < | < < < < < | < < < < < < < < < < < | < < < < < | | < < | 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 |
if (lenPtr != NULL) {
Tcl_ListObjLength(NULL, result, lenPtr);
}
return result;
}
/* Simple helper function */
Tcl_Obj*
TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
Tcl_Filesystem *fromFilesystem;
ClientData clientData;
FilesystemRecord **fsRecPtrPtr;
{
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr == fromFilesystem) {
*fsRecPtrPtr = fsRecPtr;
break;
}
fsRecPtr = fsRecPtr->nextPtr;
}
if ((fsRecPtr != NULL)
&& (fromFilesystem->internalToNormalizedProc != NULL)) {
return (*fromFilesystem->internalToNormalizedProc)(clientData);
} else {
return NULL;
}
}
/*
*----------------------------------------------------------------------
*
* GetPathType --
*
|
| ︙ | ︙ | |||
3391 3392 3393 3394 3395 3396 3397 |
/*
* Call each of the "listVolumes" function in succession, checking
* whether the given path is an absolute path on any of the volumes
* returned (this is done by checking whether the path's prefix
* matches).
*/
| | | 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 |
/*
* Call each of the "listVolumes" function in succession, checking
* whether the given path is an absolute path on any of the volumes
* returned (this is done by checking whether the path's prefix
* matches).
*/
fsRecPtr = FsGetFirstFilesystem();
while (fsRecPtr != NULL) {
Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
/*
* We want to skip the native filesystem in this loop because
* otherwise we won't necessarily pass all the Tcl testsuite --
* this is because some of the tests artificially change the
* current platform (between mac, win, unix) but the list
|
| ︙ | ︙ | |||
3465 3466 3467 3468 3469 3470 3471 |
/* We don't need to examine any more filesystems */
break;
}
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
| < | 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 |
/* We don't need to examine any more filesystems */
break;
}
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
if (type != TCL_PATH_ABSOLUTE) {
type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
driveNameRef);
if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
*filesystemPtrPtr = &tclNativeFilesystem;
}
|
| ︙ | ︙ | |||
3806 3807 3808 3809 3810 3811 3812 |
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*---------------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < | < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | | < < | < < < | < | < < < | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < | < < < < < | | < < < < < < < < < < < | < < < < < < < < < < < < < < < < | < < < < < < < < < | < < | < < < < < < < | < < < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < > | | < < | < < < < | < < | < < < < < < < < < < < < < < < < | < < < < < < < < | < < < < < < | < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < | < < < | < | < < < | < < < | < < < | < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 |
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetFileSystemForPath --
*
* This function determines which filesystem to use for a
* particular path object, and returns the filesystem which
* accepts this file. If no filesystem will accept this object
* as a valid file path, then NULL is returned.
*
* Results:
.* NULL or a filesystem which will accept this path.
*
* Side effects:
* The object may be converted to a path type.
*
*---------------------------------------------------------------------------
*/
Tcl_Filesystem*
Tcl_FSGetFileSystemForPath(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
FilesystemRecord *fsRecPtr;
Tcl_Filesystem* retVal = NULL;
/*
* If the object has a refCount of zero, we reject it. This
* is to avoid possible segfaults or nondeterministic memory
* leaks (i.e. the user doesn't know if they should decrement
* the ref count on return or not).
*/
if (pathObjPtr->refCount == 0) {
panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
/*
* Check if the filesystem has changed in some way since
* this object's internal representation was calculated.
* Before doing that, assure we have the most up-to-date
* copy of the master filesystem. This is accomplished
* by the FsGetFirstFilesystem() call.
*/
fsRecPtr = FsGetFirstFilesystem();
if (TclFSEnsureEpochOk(pathObjPtr, &retVal) != TCL_OK) {
return NULL;
}
/*
* Call each of the "pathInFilesystem" functions in succession. A
* non-return value of -1 indicates the particular function has
* succeeded.
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc;
if (proc != NULL) {
ClientData clientData = NULL;
int ret = (*proc)(pathObjPtr, &clientData);
if (ret != -1) {
/*
* We assume the type of pathObjPtr hasn't been changed
* by the above call to the pathInFilesystemProc.
*/
TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData);
retVal = fsRecPtr->fsPtr;
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetNativePath --
*
|
| ︙ | ︙ | |||
5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 |
Tcl_DString ds;
Tcl_Obj* validPathObjPtr;
int len;
char *str;
/* Make sure the normalized path is set */
validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
str = Tcl_GetStringFromObj(validPathObjPtr, &len);
#ifdef __WIN32__
Tcl_WinUtfToTChar(str, len, &ds);
if (tclWinProcs->useWide) {
len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
} else {
len = Tcl_DStringLength(&ds) + sizeof(char);
}
#else
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
#endif
nativePathPtr = ckalloc((unsigned) len);
memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);
| > > > | | 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 |
Tcl_DString ds;
Tcl_Obj* validPathObjPtr;
int len;
char *str;
/* Make sure the normalized path is set */
validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
if (validPathObjPtr == NULL) {
return NULL;
}
str = Tcl_GetStringFromObj(validPathObjPtr, &len);
#ifdef __WIN32__
Tcl_WinUtfToTChar(str, len, &ds);
if (tclWinProcs->useWide) {
len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
} else {
len = Tcl_DStringLength(&ds) + sizeof(char);
}
#else
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
#endif
nativePathPtr = ckalloc((unsigned) len);
memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);
Tcl_DStringFree(&ds);
return (ClientData)nativePathPtr;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5084 5085 5086 5087 5088 5089 5090 |
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
| | | | | 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 |
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclNativeDupInternalRep --
*
* Duplicate the native representation.
*
* Results:
* The copied native representation, or NULL if it is not possible
* to copy the representation.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
ClientData
TclNativeDupInternalRep(clientData)
ClientData clientData;
{
ClientData copy;
size_t len;
if (clientData == NULL) {
return NULL;
|
| ︙ | ︙ | |||
5125 5126 5127 5128 5129 5130 5131 |
len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
#endif
copy = (ClientData) ckalloc(len);
memcpy((VOID*)copy, (VOID*)clientData, len);
return copy;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 |
len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
#endif
copy = (ClientData) ckalloc(len);
memcpy((VOID*)copy, (VOID*)clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
* NativeFreeInternalRep --
*
* Free a native internal representation, which will be non-NULL.
|
| ︙ | ︙ | |||
5299 5300 5301 5302 5303 5304 5305 |
break;
case TCL_PLATFORM_MAC:
separator = ":";
break;
}
return Tcl_NewStringObj(separator,1);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 |
break;
case TCL_PLATFORM_MAC:
separator = ":";
break;
}
return Tcl_NewStringObj(separator,1);
}
/* Everything from here on is contained in this obsolete ifdef */
#ifdef USE_OBSOLETE_FS_HOOKS
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5544 5545 5546 5547 5548 5549 5550 |
statProcList = newStatProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
| | | 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 |
statProcList = newStatProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclStatDeleteProc --
*
|
| ︙ | ︙ | |||
5600 5601 5602 5603 5604 5605 5606 |
} else {
prevStatProcPtr = tmpStatProcPtr;
tmpStatProcPtr = tmpStatProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
| > | | 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 |
} else {
prevStatProcPtr = tmpStatProcPtr;
tmpStatProcPtr = tmpStatProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclAccessInsertProc --
*
|
| ︙ | ︙ | |||
5648 5649 5650 5651 5652 5653 5654 |
accessProcList = newAccessProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
| | | 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 |
accessProcList = newAccessProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclAccessDeleteProc --
*
|
| ︙ | ︙ | |||
5704 5705 5706 5707 5708 5709 5710 |
} else {
prevAccessProcPtr = tmpAccessProcPtr;
tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
| | | 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 |
} else {
prevAccessProcPtr = tmpAccessProcPtr;
tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclOpenFileChannelInsertProc --
*
|
| ︙ | ︙ | |||
5753 5754 5755 5756 5757 5758 5759 |
openFileChannelProcList = newOpenFileChannelProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
| | | 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 |
openFileChannelProcList = newOpenFileChannelProcPtr;
Tcl_MutexUnlock(&obsoleteFsHookMutex);
retVal = TCL_OK;
}
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* TclOpenFileChannelDeleteProc --
*
|
| ︙ | ︙ | |||
5811 5812 5813 5814 5815 5816 5817 |
} else {
prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 |
} else {
prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
}
}
Tcl_MutexUnlock(&obsoleteFsHookMutex);
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
/*
* Prototypes for procedures defined later in this file.
*/
static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr));
static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int FindSplitPos _ANSI_ARGS_((char *path, char *separator));
/*
* Define the 'path' object type, which Tcl uses to represent
* file paths internally.
*/
static Tcl_ObjType tclFsPathType = {
"path", /* name */
FreeFsPathInternalRep, /* freeIntRepProc */
DupFsPathInternalRep, /* dupIntRepProc */
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny /* setFromAnyProc */
};
/*
* struct FsPath --
*
* Internal representation of a Tcl_Obj of "path" type. This
* can be used to represent relative or absolute paths, and has
* certain optimisations when used to represent paths which are
* already normalized and absolute.
*
* Note that 'normPathPtr' can be a circular reference to the
* container Tcl_Obj of this FsPath.
*/
typedef struct FsPath {
Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences.
* If this is NULL, then this is a
* pure normalized, absolute path
* object, in which the parent Tcl_Obj's
* string rep is already both translated
* and normalized. */
Tcl_Obj *normPathPtr; /* Normalized absolute path, without
* ., .. or ~user sequences. If the
* Tcl_Obj containing
* this FsPath is already normalized,
* this may be a circular reference back
* to the container. If that is NOT the
* case, we have a refCount on the object. */
Tcl_Obj *cwdPtr; /* If null, path is absolute, else
* this points to the cwd object used
* for this path. We have a refCount
* on the object. */
int flags; /* Flags to describe interpretation */
ClientData nativePathPtr; /* Native representation of this path,
* which is filesystem dependent. */
int filesystemEpoch; /* Used to ensure the path representation
* was generated during the correct
* filesystem epoch. The epoch changes
* when filesystem-mounts are changed. */
struct FilesystemRecord *fsRecPtr;
/* Pointer to the filesystem record
* entry to use for this path. */
} FsPath;
/*
* Define some macros to give us convenient access to path-object
* specific fields.
*/
#define PATHOBJ(objPtr) (objPtr->internalRep.otherValuePtr)
#define PATHFLAGS(objPtr) \
(((FsPath*)(objPtr->internalRep.otherValuePtr))->flags)
#define TCLPATH_APPENDED 1
#define TCLPATH_RELATIVE 2
/*
*----------------------------------------------------------------------
*
* Tcl_FSGetPathType --
*
* Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute.
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_PathType
Tcl_FSGetPathType(pathObjPtr)
Tcl_Obj *pathObjPtr;
{
return FSGetPathType(pathObjPtr, NULL, NULL);
}
/*
*----------------------------------------------------------------------
*
* FSGetPathType --
*
* Determines whether a given path is relative to the current
* directory, relative to the current volume, or absolute. If the
* caller wishes to know which filesystem claimed the path (in the
* case for which the path is absolute), then a reference to a
* filesystem pointer can be passed in (but passing NULL is
* acceptable).
*
* Results:
* Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
* be set if and only if it is non-NULL and the function's
* return value is TCL_PATH_ABSOLUTE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_PathType
FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
Tcl_Obj *pathObjPtr;
Tcl_Filesystem **filesystemPtrPtr;
int *driveNameLengthPtr;
{
if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
return GetPathType(pathObjPtr, filesystemPtrPtr,
driveNameLengthPtr, NULL);
} else {
FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (fsPathPtr->cwdPtr != NULL) {
if (PATHFLAGS(pathObjPtr) == 0) {
return TCL_PATH_RELATIVE;
}
return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr,
driveNameLengthPtr);
} else {
return GetPathType(pathObjPtr, filesystemPtrPtr,
driveNameLengthPtr, NULL);
}
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSJoinPath --
*
* This function takes the given Tcl_Obj, which should be a valid
* list, and returns the path object given by considering the
* first 'elements' elements as valid path segments. If elements < 0,
* we use the entire list.
*
* Results:
* Returns object with refCount of zero, (or if non-zero, it has
* references elsewhere in Tcl). Either way, the caller must
* increment its refCount before use.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSJoinPath(listObj, elements)
Tcl_Obj *listObj;
int elements;
{
Tcl_Obj *res;
int i;
Tcl_Filesystem *fsPtr = NULL;
if (elements < 0) {
if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
return NULL;
}
} else {
/* Just make sure it is a valid list */
int listTest;
if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
return NULL;
}
/*
* Correct this if it is too large, otherwise we will
* waste our time joining null elements to the path
*/
if (elements > listTest) {
elements = listTest;
}
}
res = Tcl_NewObj();
for (i = 0; i < elements; i++) {
Tcl_Obj *elt;
int driveNameLength;
Tcl_PathType type;
char *strElt;
int strEltLen;
int length;
char *ptr;
Tcl_Obj *driveName = NULL;
Tcl_ListObjIndex(NULL, listObj, i, &elt);
/*
* This is a special case where we can be much more
* efficient, where we are joining a single relative path
* onto an object that is already of path type. The
* 'TclNewFSPathObj' call below creates an object which
* can be normalized more efficiently. Currently we only
* use the special case when we have exactly two elements,
* but we could expand that in the future.
*/
if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
&& !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
Tcl_Obj *tail;
Tcl_PathType type;
Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
type = GetPathType(tail, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
CONST char *str;
int len;
str = Tcl_GetStringFromObj(tail,&len);
if (len == 0) {
/*
* This happens if we try to handle the root volume
* '/'. There's no need to return a special path
* object, when the base itself is just fine!
*/
Tcl_DecrRefCount(res);
return elt;
}
/*
* If it doesn't begin with '.' and is a mac or unix
* path or it a windows path without backslashes, then we
* can be very efficient here. (In fact even a windows
* path with backslashes can be joined efficiently, but
* the path object would not have forward slashes only,
* and this would therefore contradict our 'file join'
* documentation).
*/
if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS)
|| (strchr(str, '\\') == NULL))) {
/*
* Finally, on Windows, 'file join' is defined to
* convert all backslashes to forward slashes,
* so the base part cannot have backslashes either.
*/
if ((tclPlatform != TCL_PLATFORM_WINDOWS)
|| (strchr(Tcl_GetString(elt), '\\') == NULL)) {
if (res != NULL) {
TclDecrRefCount(res);
}
return TclNewFSPathObj(elt, str, len);
}
}
/*
* Otherwise we don't have an easy join, and
* we must let the more general code below handle
* things
*/
} else {
if (tclPlatform == TCL_PLATFORM_UNIX) {
Tcl_DecrRefCount(res);
return tail;
} else {
CONST char *str;
int len;
str = Tcl_GetStringFromObj(tail,&len);
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
if (strchr(str, '\\') == NULL) {
Tcl_DecrRefCount(res);
return tail;
}
} else if (tclPlatform == TCL_PLATFORM_MAC) {
if (strchr(str, '/') == NULL) {
Tcl_DecrRefCount(res);
return tail;
}
}
}
}
}
strElt = Tcl_GetStringFromObj(elt, &strEltLen);
type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
/* Zero out the current result */
Tcl_DecrRefCount(res);
if (driveName != NULL) {
res = Tcl_DuplicateObj(driveName);
Tcl_DecrRefCount(driveName);
} else {
res = Tcl_NewStringObj(strElt, driveNameLength);
}
strElt += driveNameLength;
}
ptr = Tcl_GetStringFromObj(res, &length);
/*
* Strip off any './' before a tilde, unless this is the
* beginning of the path.
*/
if (length > 0 && strEltLen > 0) {
if ((strElt[0] == '.') && (strElt[1] == '/')
&& (strElt[2] == '~')) {
strElt += 2;
}
}
/*
* A NULL value for fsPtr at this stage basically means
* we're trying to join a relative path onto something
* which is also relative (or empty). There's nothing
* particularly wrong with that.
*/
if (*strElt == '\0') continue;
if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
TclpNativeJoinPath(res, strElt);
} else {
char separator = '/';
int needsSep = 0;
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
if (sep != NULL) {
separator = Tcl_GetString(sep)[0];
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
length++;
}
Tcl_SetObjLength(res, length + (int) strlen(strElt));
ptr = Tcl_GetString(res) + length;
for (; *strElt != '\0'; strElt++) {
if (*strElt == separator) {
while (strElt[1] == separator) {
strElt++;
}
if (strElt[1] != '\0') {
if (needsSep) {
*ptr++ = separator;
}
}
} else {
*ptr++ = *strElt;
needsSep = 1;
}
}
length = ptr - Tcl_GetString(res);
Tcl_SetObjLength(res, length);
}
}
return res;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSConvertToPathType --
*
* This function tries to convert the given Tcl_Obj to a valid
* Tcl path type, taking account of the fact that the cwd may
* have changed even if this object is already supposedly of
* the correct type.
*
* The filename may begin with "~" (to indicate current user's
* home directory) or "~<user>" (to indicate any user's home
* directory).
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSConvertToPathType(interp, objPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
Tcl_Obj *objPtr; /* Object to convert to a valid, current
* path type. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* While it is bad practice to examine an object's type directly,
* this is actually the best thing to do here. The reason is that
* if we are converting this object to FsPath type for the first
* time, we don't need to worry whether the 'cwd' has changed.
* On the other hand, if this object is already of FsPath type,
* and is a relative path, we do have to worry about the cwd.
* If the cwd has changed, we must recompute the path.
*/
if (objPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
if (fsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) {
if (objPtr->bytes == NULL) {
UpdateStringOfFsPath(objPtr);
}
FreeFsPathInternalRep(objPtr);
objPtr->typePtr = NULL;
return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
}
return TCL_OK;
} else {
return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
}
}
/*
* Helper function for SetFsPathFromAny. Returns position of first
* directory delimiter in the path.
*/
static int
FindSplitPos(path, separator)
char *path;
char *separator;
{
int count = 0;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
case TCL_PLATFORM_MAC:
while (path[count] != 0) {
if (path[count] == *separator) {
return count;
}
count++;
}
break;
case TCL_PLATFORM_WINDOWS:
while (path[count] != 0) {
if (path[count] == *separator || path[count] == '\\') {
return count;
}
count++;
}
break;
}
return count;
}
/*
*---------------------------------------------------------------------------
*
* TclNewFSPathObj --
*
* Creates a path object whose string representation is
* '[file join dirPtr addStrRep]', but does so in a way that
* allows for more efficient caching of normalized paths.
*
* Assumptions:
* 'dirPtr' must be an absolute path.
* 'len' may not be zero.
*
* Results:
* The new Tcl object, with refCount zero.
*
* Side effects:
* Memory is allocated. 'dirPtr' gets an additional refCount.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
{
FsPath *fsPathPtr;
Tcl_Obj *objPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
objPtr = Tcl_NewObj();
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
if (tclPlatform == TCL_PLATFORM_MAC) {
/*
* Mac relative paths may begin with a directory separator ':'.
* If present, we need to skip this ':' because we assume that
* we can join dirPtr and addStrRep by concatenating them as
* strings (and we ensure that dirPtr is terminated by a ':').
*/
if (addStrRep[0] == ':') {
addStrRep++;
len--;
}
}
/* Setup the path */
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->cwdPtr = dirPtr;
Tcl_IncrRefCount(dirPtr);
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = TCLPATH_RELATIVE | TCLPATH_APPENDED;
objPtr->typePtr = &tclFsPathType;
objPtr->bytes = NULL;
objPtr->length = 0;
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclFSMakePathRelative --
*
* Only for internal use.
*
* Takes a path and a directory, where we _assume_ both path and
* directory are absolute, normalized and that the path lies
* inside the directory. Returns a Tcl_Obj representing filename
* of the path relative to the directory.
*
* In the case where the resulting path would start with a '~', we
* take special care to return an ordinary string. This means to
* use that path (and not have it interpreted as a user name),
* one must prepend './'. This may seem strange, but that is how
* 'glob' is currently defined.
*
* Results:
* NULL on error, otherwise a valid object, typically with
* refCount of zero, which it is assumed the caller will
* increment.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
TclFSMakePathRelative(interp, objPtr, cwdPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object we have. */
Tcl_Obj *cwdPtr; /* Make it relative to this. */
{
int cwdLen, len;
CONST char *tempStr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (objPtr->typePtr == &tclFsPathType) {
FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
if (PATHFLAGS(objPtr) != 0
&& fsPathPtr->cwdPtr == cwdPtr) {
objPtr = fsPathPtr->normPathPtr;
/* Free old representation */
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't find object",
"string representation", (char *) NULL);
}
return NULL;
}
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
/* Now objPtr is a string object */
if (Tcl_GetString(objPtr)[0] == '~') {
/*
* If the first character of the path is a tilde,
* we must just return the path as is, to agree
* with the defined behaviour of 'glob'.
*/
return objPtr;
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
/* Circular reference, by design */
fsPathPtr->translatedPathPtr = objPtr;
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = cwdPtr;
Tcl_IncrRefCount(cwdPtr);
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return objPtr;
}
}
/*
* We know the cwd is a normalised object which does
* not end in a directory delimiter, unless the cwd
* is the name of a volume, in which case it will
* end in a delimiter! We handle this situation here.
* A better test than the '!= sep' might be to simply
* check if 'cwd' is a root volume.
*
* Note that if we get this wrong, we will strip off
* either too much or too little below, leading to
* wrong answers returned by glob.
*/
tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root
* volume.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (tempStr[cwdLen-1] != '/') {
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (tempStr[cwdLen-1] != '/'
&& tempStr[cwdLen-1] != '\\') {
cwdLen++;
}
break;
case TCL_PLATFORM_MAC:
if (tempStr[cwdLen-1] != ':') {
cwdLen++;
}
break;
}
tempStr = Tcl_GetStringFromObj(objPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
/*
*---------------------------------------------------------------------------
*
* TclFSMakePathFromNormalized --
*
* Like SetFsPathFromAny, but assumes the given object is an
* absolute normalized path. Only for internal use.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
int
TclFSMakePathFromNormalized(interp, objPtr, nativeRep)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object to convert. */
ClientData nativeRep; /* The native rep for the object, if known
* else NULL. */
{
FsPath *fsPathPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (objPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
/* Free old representation */
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't find object",
"string representation", (char *) NULL);
}
return TCL_ERROR;
}
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
/* It's a pure normalized absolute path */
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = objPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = nativeRep;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSNewNativePath --
*
* This function performs the something like that reverse of the
* usual obj->path->nativerep conversions. If some code retrieves
* a path in native form (from, e.g. readlink or a native dialog),
* and that path is to be used at the Tcl level, then calling
* this function is an efficient way of creating the appropriate
* path object type.
*
* Any memory which is allocated for 'clientData' should be retained
* until clientData is passed to the filesystem's freeInternalRepProc
* when it can be freed. The built in platform-specific filesystems
* use 'ckalloc' to allocate clientData, and ckfree to free it.
*
* Results:
* NULL or a valid path object pointer, with refCount zero.
*
* Side effects:
* New memory may be allocated.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSNewNativePath(fromFilesystem, clientData)
Tcl_Filesystem* fromFilesystem;
ClientData clientData;
{
Tcl_Obj *objPtr;
FsPath *fsPathPtr;
FilesystemRecord *fsFromPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
objPtr = TclFSInternalToNormalized(fromFilesystem, clientData, &fsFromPtr);
if (objPtr == NULL) {
return NULL;
}
/*
* Free old representation; shouldn't normally be any,
* but best to be safe.
*/
if (objPtr->typePtr != NULL) {
if (objPtr->bytes == NULL) {
if (objPtr->typePtr->updateStringProc == NULL) {
return NULL;
}
objPtr->typePtr->updateStringProc(objPtr);
}
if ((objPtr->typePtr->freeIntRepProc) != NULL) {
(*objPtr->typePtr->freeIntRepProc)(objPtr);
}
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
/* Circular reference, by design */
fsPathPtr->normPathPtr = objPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsRecPtr = fsFromPtr;
fsPathPtr->fsRecPtr->fileRefCount++;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return objPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetTranslatedPath --
*
* This function attempts to extract the translated path
* from the given Tcl_Obj. If the translation succeeds (i.e. the
* object is a valid path), then it is returned. Otherwise NULL
* will be returned, and an error message may be left in the
* interpreter (if it is non-NULL)
*
* Results:
* NULL or a valid Tcl_Obj pointer.
*
* Side effects:
* Only those of 'Tcl_FSConvertToPathType'
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSGetTranslatedPath(interp, pathPtr)
Tcl_Interp *interp;
Tcl_Obj* pathPtr;
{
Tcl_Obj *retObj = NULL;
FsPath *srcFsPathPtr;
if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return NULL;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
if (srcFsPathPtr->translatedPathPtr == NULL) {
if (PATHFLAGS(pathPtr) != 0) {
retObj = Tcl_FSGetNormalizedPath(interp, pathPtr);
} else {
/*
* It is a pure absolute, normalized path object.
* This is something like being a 'pure list'. The
* object's string, translatedPath and normalizedPath
* are all identical.
*/
retObj = srcFsPathPtr->normPathPtr;
}
} else {
/* It is an ordinary path object */
retObj = srcFsPathPtr->translatedPathPtr;
}
if (retObj) {
Tcl_IncrRefCount(retObj);
}
return retObj;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetTranslatedStringPath --
*
* This function attempts to extract the translated path
* from the given Tcl_Obj. If the translation succeeds (i.e. the
* object is a valid path), then the path is returned. Otherwise NULL
* will be returned, and an error message may be left in the
* interpreter (if it is non-NULL)
*
* Results:
* NULL or a valid string.
*
* Side effects:
* Only those of 'Tcl_FSConvertToPathType'
*
*---------------------------------------------------------------------------
*/
CONST char*
Tcl_FSGetTranslatedStringPath(interp, pathPtr)
Tcl_Interp *interp;
Tcl_Obj* pathPtr;
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
int len;
CONST char *result, *orig;
orig = Tcl_GetStringFromObj(transPtr, &len);
result = (char*) ckalloc((unsigned)(len+1));
memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1));
Tcl_DecrRefCount(transPtr);
return result;
}
return NULL;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetNormalizedPath --
*
* This important function attempts to extract from the given Tcl_Obj
* a unique normalised path representation, whose string value can
* be used as a unique identifier for the file.
*
* Results:
* NULL or a valid path object pointer.
*
* Side effects:
* New memory may be allocated. The Tcl 'errno' may be modified
* in the process of trying to examine various path possibilities.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj*
Tcl_FSGetNormalizedPath(interp, pathObjPtr)
Tcl_Interp *interp;
Tcl_Obj* pathObjPtr;
{
FsPath *fsPathPtr;
if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) {
return NULL;
}
fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (PATHFLAGS(pathObjPtr) != 0) {
/*
* This is a special path object which is the result of
* something like 'file join'
*/
Tcl_Obj *dir, *copy;
int cwdLen;
int pathType;
CONST char *cwdStr;
ClientData clientData = NULL;
pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
if (dir == NULL) {
return NULL;
}
if (pathObjPtr->bytes == NULL) {
UpdateStringOfFsPath(pathObjPtr);
}
copy = Tcl_DuplicateObj(dir);
Tcl_IncrRefCount(copy);
Tcl_IncrRefCount(dir);
/* We now own a reference on both 'dir' and 'copy' */
cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root volume.
* We should never get cwdLen == 0 in this code path.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (cwdStr[cwdLen-1] != '/') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (cwdStr[cwdLen-1] != '/'
&& cwdStr[cwdLen-1] != '\\') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_MAC:
if (cwdStr[cwdLen-1] != ':') {
Tcl_AppendToObj(copy, ":", 1);
cwdLen++;
}
break;
}
Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
/*
* Normalize the combined string, but only starting after
* the end of the previously normalized 'dir'. This should
* be much faster! We use 'cwdLen-1' so that we are
* already pointing at the dir-separator that we know about.
* The normalization code will actually start off directly
* after that separator.
*/
TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
/* Now we need to construct the new path object */
if (pathType == TCL_PATH_RELATIVE) {
FsPath* origDirFsPathPtr;
Tcl_Obj *origDir = fsPathPtr->cwdPtr;
origDirFsPathPtr = (FsPath*) PATHOBJ(origDir);
fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
Tcl_IncrRefCount(fsPathPtr->cwdPtr);
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
/* That's our reference to copy used */
Tcl_DecrRefCount(dir);
Tcl_DecrRefCount(origDir);
} else {
Tcl_DecrRefCount(fsPathPtr->cwdPtr);
fsPathPtr->cwdPtr = NULL;
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
/* That's our reference to copy used */
Tcl_DecrRefCount(dir);
}
if (clientData != NULL) {
fsPathPtr->nativePathPtr = clientData;
}
PATHFLAGS(pathObjPtr) = 0;
}
/* Ensure cwd hasn't changed */
if (fsPathPtr->cwdPtr != NULL) {
if (!TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) {
if (pathObjPtr->bytes == NULL) {
UpdateStringOfFsPath(pathObjPtr);
}
FreeFsPathInternalRep(pathObjPtr);
pathObjPtr->typePtr = NULL;
if (Tcl_ConvertToType(interp, pathObjPtr,
&tclFsPathType) != TCL_OK) {
return NULL;
}
fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
int cwdLen;
Tcl_Obj *copy;
CONST char *cwdStr;
ClientData clientData = NULL;
copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
Tcl_IncrRefCount(copy);
cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root volume.
* We should never get cwdLen == 0 in this code path.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (cwdStr[cwdLen-1] != '/') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
if (cwdStr[cwdLen-1] != '/'
&& cwdStr[cwdLen-1] != '\\') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_MAC:
if (cwdStr[cwdLen-1] != ':') {
Tcl_AppendToObj(copy, ":", 1);
cwdLen++;
}
break;
}
Tcl_AppendObjToObj(copy, pathObjPtr);
/*
* Normalize the combined string, but only starting after
* the end of the previously normalized 'dir'. This should
* be much faster!
*/
TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
fsPathPtr->normPathPtr = copy;
if (clientData != NULL) {
fsPathPtr->nativePathPtr = clientData;
}
}
}
if (fsPathPtr->normPathPtr == NULL) {
ClientData clientData = NULL;
Tcl_Obj *useThisCwd = NULL;
/*
* Since normPathPtr is NULL, but this is a valid path
* object, we know that the translatedPathPtr cannot be NULL.
*/
Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
char *path = Tcl_GetString(absolutePath);
/*
* We have to be a little bit careful here to avoid infinite loops
* we're asking Tcl_FSGetPathType to return the path's type, but
* that call can actually result in a lot of other filesystem
* action, which might loop back through here.
*/
if (path[0] != '\0') {
Tcl_PathType type = Tcl_FSGetPathType(pathObjPtr);
if (type == TCL_PATH_RELATIVE) {
useThisCwd = Tcl_FSGetCwd(interp);
if (useThisCwd == NULL) return NULL;
absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
Tcl_IncrRefCount(absolutePath);
/* We have a refCount on the cwd */
#ifdef __WIN32__
} else if (type == TCL_PATH_VOLUME_RELATIVE) {
/*
* Only Windows has volume-relative paths. These
* paths are rather rare, but is is nice if Tcl can
* handle them. It is much better if we can
* handle them here, rather than in the native fs code,
* because we really need to have a real absolute path
* just below.
*
* We do not let this block compile on non-Windows
* platforms because the test suite's manual forcing
* of tclPlatform can otherwise cause this code path
* to be executed, causing various errors because
* volume-relative paths really do not exist.
*/
useThisCwd = Tcl_FSGetCwd(interp);
if (useThisCwd == NULL) return NULL;
if (path[0] == '/') {
/*
* Path of form /foo/bar which is a path in the
* root directory of the current volume.
*/
CONST char *drive = Tcl_GetString(useThisCwd);
absolutePath = Tcl_NewStringObj(drive,2);
Tcl_AppendToObj(absolutePath, path, -1);
Tcl_IncrRefCount(absolutePath);
/* We have a refCount on the cwd */
} else {
/*
* Path of form C:foo/bar, but this only makes
* sense if the cwd is also on drive C.
*/
CONST char *drive = Tcl_GetString(useThisCwd);
char drive_c = path[0];
if (drive_c >= 'a') {
drive_c -= ('a' - 'A');
}
if (drive[0] == drive_c) {
absolutePath = Tcl_DuplicateObj(useThisCwd);
/* We have a refCount on the cwd */
} else {
Tcl_DecrRefCount(useThisCwd);
useThisCwd = NULL;
/*
* The path is not in the current drive, but
* is volume-relative. The way Tcl 8.3 handles
* this is that it treats such a path as
* relative to the root of the drive. We
* therefore behave the same here.
*/
absolutePath = Tcl_NewStringObj(path, 2);
}
Tcl_IncrRefCount(absolutePath);
Tcl_AppendToObj(absolutePath, "/", 1);
Tcl_AppendToObj(absolutePath, path+2, -1);
}
#endif /* __WIN32__ */
}
}
/* Already has refCount incremented */
fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath,
(fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
if (0 && (clientData != NULL)) {
fsPathPtr->nativePathPtr =
(*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData);
}
if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr),
Tcl_GetString(pathObjPtr))) {
/*
* The path was already normalized.
* Get rid of the duplicate.
*/
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
/*
* We do *not* increment the refCount for
* this circular reference
*/
fsPathPtr->normPathPtr = pathObjPtr;
}
if (useThisCwd != NULL) {
/* This was returned by Tcl_FSJoinToPath above */
Tcl_DecrRefCount(absolutePath);
fsPathPtr->cwdPtr = useThisCwd;
}
}
return fsPathPtr->normPathPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetInternalRep --
*
* Extract the internal representation of a given path object,
* in the given filesystem. If the path object belongs to a
* different filesystem, we return NULL.
*
* If the internal representation is currently NULL, we attempt
* to generate it, by calling the filesystem's
* 'Tcl_FSCreateInternalRepProc'.
*
* Results:
* NULL or a valid internal representation.
*
* Side effects:
* An attempt may be made to convert the object.
*
*---------------------------------------------------------------------------
*/
ClientData
Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
Tcl_Obj* pathObjPtr;
Tcl_Filesystem *fsPtr;
{
FsPath *srcFsPathPtr;
if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
return NULL;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
/*
* We will only return the native representation for the caller's
* filesystem. Otherwise we will simply return NULL. This means
* that there must be a unique bi-directional mapping between paths
* and filesystems, and that this mapping will not allow 'remapped'
* files -- files which are in one filesystem but mapped into
* another. Another way of putting this is that 'stacked'
* filesystems are not allowed. We recognise that this is a
* potentially useful feature for the future.
*
* Even something simple like a 'pass through' filesystem which
* logs all activity and passes the calls onto the native system
* would be nice, but not easily achievable with the current
* implementation.
*/
if (srcFsPathPtr->fsRecPtr == NULL) {
/*
* This only usually happens in wrappers like TclpStat which
* create a string object and pass it to TclpObjStat. Code
* which calls the Tcl_FS.. functions should always have a
* filesystem already set. Whether this code path is legal or
* not depends on whether we decide to allow external code to
* call the native filesystem directly. It is at least safer
* to allow this sub-optimal routing.
*/
Tcl_FSGetFileSystemForPath(pathObjPtr);
/*
* If we fail through here, then the path is probably not a
* valid path in the filesystsem, and is most likely to be a
* use of the empty path "" via a direct call to one of the
* objectified interfaces (e.g. from the Tcl testsuite).
*/
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (srcFsPathPtr->fsRecPtr == NULL) {
return NULL;
}
}
if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
/*
* There is still one possibility we should consider; if the
* file belongs to a different filesystem, perhaps it is
* actually linked through to a file in our own filesystem
* which we do care about. The way we can check for this
* is we ask what filesystem this path belongs to.
*/
Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr);
if (actualFs == fsPtr) {
return Tcl_FSGetInternalRep(pathObjPtr, fsPtr);
}
return NULL;
}
if (srcFsPathPtr->nativePathPtr == NULL) {
Tcl_FSCreateInternalRepProc *proc;
char *nativePathPtr;
proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc;
if (proc == NULL) {
return NULL;
}
nativePathPtr = (*proc)(pathObjPtr);
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
srcFsPathPtr->nativePathPtr = nativePathPtr;
}
return srcFsPathPtr->nativePathPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclFSEnsureEpochOk --
*
* This will ensure the pathObjPtr is up to date and can be
* converted into a "path" type, and that we are able to generate a
* complete normalized path which is used to determine the
* filesystem match.
*
* Results:
* Standard Tcl return code.
*
* Side effects:
* An attempt may be made to convert the object.
*
*---------------------------------------------------------------------------
*/
int
TclFSEnsureEpochOk(pathObjPtr, fsPtrPtr)
Tcl_Obj* pathObjPtr;
Tcl_Filesystem **fsPtrPtr;
{
FsPath *srcFsPathPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* SHOULD BE ABLE TO IMPROVE EFFICIENCY HERE.
*/
if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
return TCL_ERROR;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
/*
* Check if the filesystem has changed in some way since
* this object's internal representation was calculated.
*/
if (srcFsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) {
/*
* We have to discard the stale representation and
* recalculate it
*/
if (pathObjPtr->bytes == NULL) {
UpdateStringOfFsPath(pathObjPtr);
}
FreeFsPathInternalRep(pathObjPtr);
pathObjPtr->typePtr = NULL;
if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) {
return TCL_ERROR;
}
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
}
/* Check whether the object is already assigned to a fs */
if (srcFsPathPtr->fsRecPtr != NULL) {
*fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr;
}
return TCL_OK;
}
void
TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData)
Tcl_Obj *pathObjPtr;
FilesystemRecord *fsRecPtr;
ClientData clientData;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/* We assume pathObjPtr is already of the correct type */
FsPath *srcFsPathPtr;
srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
srcFsPathPtr->fsRecPtr = fsRecPtr;
srcFsPathPtr->nativePathPtr = clientData;
srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
fsRecPtr->fileRefCount++;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSEqualPaths --
*
* This function tests whether the two paths given are equal path
* objects. If either or both is NULL, 0 is always returned.
*
* Results:
* 1 or 0.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSEqualPaths(firstPtr, secondPtr)
Tcl_Obj* firstPtr;
Tcl_Obj* secondPtr;
{
if (firstPtr == secondPtr) {
return 1;
} else {
char *firstStr, *secondStr;
int firstLen, secondLen, tempErrno;
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
return 1;
}
/*
* Try the most thorough, correct method of comparing fully
* normalized paths
*/
tempErrno = Tcl_GetErrno();
firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
Tcl_SetErrno(tempErrno);
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
}
firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
return 1;
}
}
return 0;
}
/*
*---------------------------------------------------------------------------
*
* SetFsPathFromAny --
*
* This function tries to convert the given Tcl_Obj to a valid
* Tcl path type.
*
* The filename may begin with "~" (to indicate current user's
* home directory) or "~<user>" (to indicate any user's home
* directory).
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
static int
SetFsPathFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr; /* The object to convert. */
{
int len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
char *name;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (objPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
/*
* First step is to translate the filename. This is similar to
* Tcl_TranslateFilename, but shouldn't convert everything to
* windows backslashes on that platform. The current
* implementation of this piece is a slightly optimised version
* of the various Tilde/Split/Join stuff to avoid multiple
* split/join operations.
*
* We remove any trailing directory separator.
*
* However, the split/join routines are quite complex, and
* one has to make sure not to break anything on Unix, Win
* or MacOS (fCmd.test, fileName.test and cmdAH.test exercise
* most of the code).
*/
name = Tcl_GetStringFromObj(objPtr,&len);
/*
* Handle tilde substitutions, if needed.
*/
if (name[0] == '~') {
char *expandedUser;
Tcl_DString temp;
int split;
char separator='/';
if (tclPlatform==TCL_PLATFORM_MAC) {
if (strchr(name, ':') != NULL) separator = ':';
}
split = FindSplitPos(name, &separator);
if (split != len) {
/* We have multiple pieces '~user/foo/bar...' */
name[split] = '\0';
}
/* Do some tilde substitution */
if (name[1] == '\0') {
/* We have just '~' */
CONST char *dir;
Tcl_DString dirString;
if (split != len) { name[split] = separator; }
dir = TclGetEnv("HOME", &dirString);
if (dir == NULL) {
if (interp) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't find HOME environment ",
"variable to expand path", (char *) NULL);
}
return TCL_ERROR;
}
Tcl_DStringInit(&temp);
Tcl_JoinPath(1, &dir, &temp);
Tcl_DStringFree(&dirString);
} else {
/* We have a user name '~user' */
Tcl_DStringInit(&temp);
if (TclpGetUserHome(name+1, &temp) == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "user \"", (name+1),
"\" doesn't exist", (char *) NULL);
}
Tcl_DStringFree(&temp);
if (split != len) { name[split] = separator; }
return TCL_ERROR;
}
if (split != len) { name[split] = separator; }
}
expandedUser = Tcl_DStringValue(&temp);
transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));
if (split != len) {
/* Join up the tilde substitution with the rest */
if (name[split+1] == separator) {
/*
* Somewhat tricky case like ~//foo/bar.
* Make use of Split/Join machinery to get it right.
* Assumes all paths beginning with ~ are part of the
* native filesystem.
*/
int objc;
Tcl_Obj **objv;
Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL);
Tcl_ListObjGetElements(NULL, parts, &objc, &objv);
/* Skip '~'. It's replaced by its expansion */
objc--; objv++;
while (objc--) {
TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
}
Tcl_DecrRefCount(parts);
} else {
/* Simple case. "rest" is relative path. Just join it. */
Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1);
transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest);
}
}
Tcl_DStringFree(&temp);
} else {
transPtr = Tcl_FSJoinToPath(objPtr,0,NULL);
}
#if defined(__CYGWIN__) && defined(__WIN32__)
{
extern int cygwin_conv_to_win32_path
_ANSI_ARGS_((CONST char *, char *));
char winbuf[MAX_PATH+1];
/*
* In the Cygwin world, call conv_to_win32_path in order to use the
* mount table to translate the file name into something Windows will
* understand. Take care when converting empty strings!
*/
name = Tcl_GetStringFromObj(transPtr, &len);
if (len > 0) {
cygwin_conv_to_win32_path(name, winbuf);
TclWinNoBackslash(winbuf);
Tcl_SetStringObj(transPtr, winbuf, -1);
}
}
#endif /* __CYGWIN__ && __WIN32__ */
/*
* Now we have a translated filename in 'transPtr'. This will have
* forward slashes on Windows, and will not contain any ~user
* sequences.
*/
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
fsPathPtr->translatedPathPtr = transPtr;
Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
/*
* Free old representation before installing our new one.
*/
if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
(objPtr->typePtr->freeIntRepProc)(objPtr);
}
PATHOBJ(objPtr) = (VOID *) fsPathPtr;
PATHFLAGS(objPtr) = 0;
objPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
static void
FreeFsPathInternalRep(pathObjPtr)
Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */
{
FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
if (fsPathPtr->translatedPathPtr != NULL) {
if (fsPathPtr->translatedPathPtr != pathObjPtr) {
Tcl_DecrRefCount(fsPathPtr->translatedPathPtr);
}
}
if (fsPathPtr->normPathPtr != NULL) {
if (fsPathPtr->normPathPtr != pathObjPtr) {
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
}
fsPathPtr->normPathPtr = NULL;
}
if (fsPathPtr->cwdPtr != NULL) {
Tcl_DecrRefCount(fsPathPtr->cwdPtr);
}
if (fsPathPtr->nativePathPtr != NULL) {
if (fsPathPtr->fsRecPtr != NULL) {
if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) {
(*fsPathPtr->fsRecPtr->fsPtr
->freeInternalRepProc)(fsPathPtr->nativePathPtr);
fsPathPtr->nativePathPtr = NULL;
}
}
}
if (fsPathPtr->fsRecPtr != NULL) {
fsPathPtr->fsRecPtr->fileRefCount--;
if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {
/* It has been unregistered already, so simply free it */
ckfree((char *)fsPathPtr->fsRecPtr);
}
}
ckfree((char*) fsPathPtr);
}
static void
DupFsPathInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */
Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = (FsPath*) PATHOBJ(srcPtr);
FsPath *copyFsPathPtr = (FsPath*) ckalloc((unsigned)sizeof(FsPath));
Tcl_FSDupInternalRepProc *dupProc;
PATHOBJ(copyPtr) = (VOID *) copyFsPathPtr;
if (srcFsPathPtr->translatedPathPtr != NULL) {
copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
if (copyFsPathPtr->translatedPathPtr != copyPtr) {
Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
}
} else {
copyFsPathPtr->translatedPathPtr = NULL;
}
if (srcFsPathPtr->normPathPtr != NULL) {
copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
if (copyFsPathPtr->normPathPtr != copyPtr) {
Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
}
} else {
copyFsPathPtr->normPathPtr = NULL;
}
if (srcFsPathPtr->cwdPtr != NULL) {
copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
} else {
copyFsPathPtr->cwdPtr = NULL;
}
copyFsPathPtr->flags = srcFsPathPtr->flags;
if (srcFsPathPtr->fsRecPtr != NULL
&& srcFsPathPtr->nativePathPtr != NULL) {
dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc;
if (dupProc != NULL) {
copyFsPathPtr->nativePathPtr =
(*dupProc)(srcFsPathPtr->nativePathPtr);
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
} else {
copyFsPathPtr->nativePathPtr = NULL;
}
copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr;
copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
if (copyFsPathPtr->fsRecPtr != NULL) {
copyFsPathPtr->fsRecPtr->fileRefCount++;
}
copyPtr->typePtr = &tclFsPathType;
}
/*
*---------------------------------------------------------------------------
*
* UpdateStringOfFsPath --
*
* Gives an object a valid string rep.
*
* Results:
* None.
*
* Side effects:
* Memory may be allocated.
*
*---------------------------------------------------------------------------
*/
static void
UpdateStringOfFsPath(objPtr)
register Tcl_Obj *objPtr; /* path obj with string rep to update. */
{
FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
CONST char *cwdStr;
int cwdLen;
Tcl_Obj *copy;
if (PATHFLAGS(objPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
panic("Called UpdateStringOfFsPath with invalid object");
}
copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
Tcl_IncrRefCount(copy);
cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
/*
* Should we perhaps use 'Tcl_FSPathSeparator'?
* But then what about the Windows special case?
* Perhaps we should just check if cwd is a root volume.
* We should never get cwdLen == 0 in this code path.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
if (cwdStr[cwdLen-1] != '/') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
break;
case TCL_PLATFORM_WINDOWS:
/*
* We need the extra 'cwdLen != 2', and ':' checks because
* a volume relative path doesn't get a '/'. For example
* 'glob C:*cat*.exe' will return 'C:cat32.exe'
*/
if (cwdStr[cwdLen-1] != '/'
&& cwdStr[cwdLen-1] != '\\') {
if (cwdLen != 2 || cwdStr[1] != ':') {
Tcl_AppendToObj(copy, "/", 1);
cwdLen++;
}
}
break;
case TCL_PLATFORM_MAC:
if (cwdStr[cwdLen-1] != ':') {
Tcl_AppendToObj(copy, ":", 1);
cwdLen++;
}
break;
}
Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
objPtr->length = cwdLen;
copy->bytes = tclEmptyStringRep;
copy->length = 0;
Tcl_DecrRefCount(copy);
}
/*
*---------------------------------------------------------------------------
*
* NativePathInFilesystem --
*
* Any path object is acceptable to the native filesystem, by
* default (we will throw errors when illegal paths are actually
* tried to be used).
*
* However, this behavior means the native filesystem must be
* the last filesystem in the lookup list (otherwise it will
* claim all files belong to it, and other filesystems will
* never get a look in).
*
* Results:
* TCL_OK, to indicate 'yes', -1 to indicate no.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
NativePathInFilesystem(pathPtr, clientDataPtr)
Tcl_Obj *pathPtr;
ClientData *clientDataPtr;
{
/*
* A special case is required to handle the empty path "".
* This is a valid path (i.e. the user should be able
* to do 'file exists ""' without throwing an error), but
* equally the path doesn't exist. Those are the semantics
* of Tcl (at present anyway), so we have to abide by them
* here.
*/
if (pathPtr->typePtr == &tclFsPathType) {
if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
/* We reject the empty path "" */
return -1;
}
/* Otherwise there is no way this path can be empty */
} else {
/*
* It is somewhat unusual to reach this code path without
* the object being of tclFsPathType. However, we do
* our best to deal with the situation.
*/
int len;
Tcl_GetStringFromObj(pathPtr,&len);
if (len == 0) {
/* We reject the empty path "" */
return -1;
}
}
/*
* Path is of correct type, or is of non-zero length,
* so we accept it.
*/
return TCL_OK;
}
|
Changes to generic/tclIndexObj.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclIndexObj.c -- * * This file implements objects of type "index". This object type * is used to lookup a keyword in a table of valid values and cache * the index of the matching entry. * * Copyright (c) 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclIndexObj.c -- * * This file implements objects of type "index". This object type * is used to lookup a keyword in a table of valid values and cache * the index of the matching entry. * * Copyright (c) 1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIndexObj.c,v 1.16.2.5 2006/04/06 18:57:24 dgp Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * Prototypes for procedures defined later in this file: |
| ︙ | ︙ | |||
167 168 169 170 171 172 173 |
* etc. The last entry must be NULL
* and there must not be duplicate entries. */
int offset; /* The number of bytes between entries */
CONST char *msg; /* Identifying word to use in error messages. */
int flags; /* 0 or TCL_EXACT */
int *indexPtr; /* Place to store resulting integer index. */
{
| | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
* etc. The last entry must be NULL
* and there must not be duplicate entries. */
int offset; /* The number of bytes between entries */
CONST char *msg; /* Identifying word to use in error messages. */
int flags; /* 0 or TCL_EXACT */
int *indexPtr; /* Place to store resulting integer index. */
{
int index, i, numAbbrev;
char *key, *p1;
CONST char *p2;
CONST char * CONST *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
/*
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
}
/*
* Lookup the value of the object in the table. Accept unique
* abbreviations unless TCL_EXACT is set in flags.
*/
| | < < < < < < < < | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 |
}
/*
* Lookup the value of the object in the table. Accept unique
* abbreviations unless TCL_EXACT is set in flags.
*/
key = TclGetString(objPtr);
index = -1;
numAbbrev = 0;
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
* - A single abbreviation (allowed depending on flags)
* - Several abbreviations (never allowed, but overridden by exact match)
*/
for (entryPtr = tablePtr, i = 0; *entryPtr != NULL;
|
| ︙ | ︙ | |||
231 232 233 234 235 236 237 |
*/
numAbbrev++;
index = i;
}
}
/*
| | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
*/
numAbbrev++;
index = i;
}
}
/*
* Check if we were instructed to disallow abbreviations.
*/
if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) {
goto error;
}
done:
/*
* Cache the found representation. Note that we want to avoid
* allocating a new internal-rep if at all possible since that is
|
| ︙ | ︙ | |||
267 268 269 270 271 272 273 |
error:
if (interp != NULL) {
/*
* Produce a fancy error message.
*/
int count;
| > > | | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
error:
if (interp != NULL) {
/*
* Produce a fancy error message.
*/
int count;
TclNewObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) &&
!(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"",
key, "\": must be ", STRING_AT(tablePtr,offset,0), (char*)NULL);
for (entryPtr = NEXT_ENTRY(tablePtr, offset), count = 0;
*entryPtr != NULL;
entryPtr = NEXT_ENTRY(entryPtr, offset), count++) {
if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
Tcl_AppendStringsToObj(resultPtr,
(count > 0) ? ", or " : " or ", *entryPtr,
|
| ︙ | ︙ | |||
446 447 448 449 450 451 452 |
* leading objects in objv. The
* message may be NULL. */
{
Tcl_Obj *objPtr;
int i;
register IndexRep *indexRep;
| > | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
* leading objects in objv. The
* message may be NULL. */
{
Tcl_Obj *objPtr;
int i;
register IndexRep *indexRep;
TclNewObj(objPtr);
Tcl_SetObjResult(interp, objPtr);
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
for (i = 0; i < objc; i++) {
/*
* If the object is an index type use the index table which allows
* for the correct error message even if the subcommand was
* abbreviated. Otherwise, just use the string rep.
*/
|
| ︙ | ︙ |
Changes to generic/tclInt.decls.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: tclInt.decls,v 1.59.2.7 2007/04/21 19:52:14 kennykb Exp $ library tcl # Define the unsupported generic interfaces. interface tclInt |
| ︙ | ︙ | |||
120 121 122 123 124 125 126 |
void TclFreePackageInfo(Interp *iPtr)
}
# Removed in 8.1:
# declare 26 generic {
# char * TclGetCwd(Tcl_Interp *interp)
# }
declare 27 generic {
| | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
void TclFreePackageInfo(Interp *iPtr)
}
# Removed in 8.1:
# declare 26 generic {
# char * TclGetCwd(Tcl_Interp *interp)
# }
declare 27 generic {
int TclGetDate(char *p, Tcl_WideInt now, long zone,
Tcl_WideInt *timePtr)
}
declare 28 generic {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
# Removed in 8.4b2:
#declare 29 generic {
# Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp,
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
# deprecated
declare 77 generic {
void TclpGetTime(Tcl_Time *time)
}
declare 78 generic {
| | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
# deprecated
declare 77 generic {
void TclpGetTime(Tcl_Time *time)
}
declare 78 generic {
int TclpGetTimeZone(Tcl_WideInt time)
}
# Replaced by Tcl_FSListVolumes in 8.4:
#declare 79 generic {
# int TclpListVolumes(Tcl_Interp *interp)
#}
# Replaced by Tcl_FSOpenFileChannel in 8.4:
#declare 80 generic {
|
| ︙ | ︙ | |||
692 693 694 695 696 697 698 699 700 701 702 703 704 705 |
# added for 8.4.2
declare 173 generic {
int TclUniCharMatch (CONST Tcl_UniChar *string, int strLen, \
CONST Tcl_UniChar *pattern, int ptnLen, int nocase)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
| > > > > > > > > > > > > > | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
# added for 8.4.2
declare 173 generic {
int TclUniCharMatch (CONST Tcl_UniChar *string, int strLen, \
CONST Tcl_UniChar *pattern, int ptnLen, int nocase)
}
# TclpGmtime and TclpLocaltime promoted to the generic interface from unix
declare 182 generic {
struct tm *TclpLocaltime(TclpTime_t_CONST clock)
}
declare 183 generic {
struct tm *TclpGmtime(TclpTime_t_CONST clock)
}
declare 199 generic {
int TclMatchIsTrivial(CONST char *pattern)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
|
| ︙ | ︙ | |||
923 924 925 926 927 928 929 930 931 932 933 934 935 936 |
}
# Added in 8.4.2
declare 28 win {
void TclWinResetInterfaces(void)
}
#########################
# Unix specific internals
# Pipe channel functions
declare 0 unix {
| > > > > | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
}
# Added in 8.4.2
declare 28 win {
void TclWinResetInterfaces(void)
}
declare 29 win {
int TclWinCPUID( unsigned int index, unsigned int *regs )
}
#########################
# Unix specific internals
# Pipe channel functions
declare 0 unix {
|
| ︙ | ︙ | |||
972 973 974 975 976 977 978 979 980 |
}
# Added in 8.4:
declare 10 unix {
Tcl_DirEntry * TclpReaddir(DIR * dir)
}
declare 11 unix {
| > > > | | | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 |
}
# Added in 8.4:
declare 10 unix {
Tcl_DirEntry * TclpReaddir(DIR * dir)
}
# Slots 11 and 12 are forwarders for functions that were promoted to
# generic Stubs
declare 11 unix {
struct tm * TclpLocaltime_unix(TclpTime_t_CONST clock)
}
declare 12 unix {
struct tm * TclpGmtime_unix(TclpTime_t_CONST clock)
}
declare 13 unix {
char * TclpInetNtoa(struct in_addr addr)
}
|
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclInt.h,v 1.118.2.28 2007/05/10 21:32:17 dgp Exp $ */ #ifndef _TCLINT #define _TCLINT /* * Common include files needed by most of the Tcl source files are |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 54 55 56 57 58 59 60 | #endif #ifdef NO_STRING_H #include "../compat/string.h" #else #include <string.h> #endif #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | #endif #ifdef NO_STRING_H #include "../compat/string.h" #else #include <string.h> #endif /* * Ensure WORDS_BIGENDIAN is defined correcly: * Needs to happen here in addition to configure to work with fat compiles on * Darwin (where configure runs only once for multiple architectures). */ #ifdef HAVE_SYS_TYPES_H # include <sys/types.h> #endif #ifdef HAVE_SYS_PARAM_H # include <sys/param.h> #endif #ifdef BYTE_ORDER # ifdef BIG_ENDIAN # if BYTE_ORDER == BIG_ENDIAN # undef WORDS_BIGENDIAN # define WORDS_BIGENDIAN # endif # endif # ifdef LITTLE_ENDIAN # if BYTE_ORDER == LITTLE_ENDIAN # undef WORDS_BIGENDIAN # endif # endif #endif /* * Used to tag functions that are only to be visible within the module being * built and not outside it (where this is supported by the linker). */ #ifndef MODULE_SCOPE # ifdef __cplusplus # define MODULE_SCOPE extern "C" # else # define MODULE_SCOPE extern # endif #endif #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT #else # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else |
| ︙ | ︙ | |||
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 | * namespace and no call frames still refer to it. Its * variables and command have already been destroyed. This bit * allows the namespace resolution code to recognize that the * namespace is "deleted". When the last namespaceName object * in any byte code code unit that refers to the namespace has * been freed (i.e., when the namespace's refCount is 0), the * namespace's storage will be freed. */ #define NS_DYING 0x01 #define NS_DEAD 0x02 /* * Flag passed to TclGetNamespaceForQualName to have it create all namespace * components of a namespace-qualified name that cannot be found. The new * namespaces are created within their specified parent. Note that this * flag's value must not conflict with the values of the flags * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, and FIND_ONLY_NS (defined in | > > > | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 | * namespace and no call frames still refer to it. Its * variables and command have already been destroyed. This bit * allows the namespace resolution code to recognize that the * namespace is "deleted". When the last namespaceName object * in any byte code code unit that refers to the namespace has * been freed (i.e., when the namespace's refCount is 0), the * namespace's storage will be freed. * NS_KILLED 1 means that TclTeardownNamespace has already been called on * this namespace and it should not be called again [Bug 1355942] */ #define NS_DYING 0x01 #define NS_DEAD 0x02 #define NS_KILLED 0x04 /* * Flag passed to TclGetNamespaceForQualName to have it create all namespace * components of a namespace-qualified name that cannot be found. The new * namespaces are created within their specified parent. Note that this * flag's value must not conflict with the values of the flags * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, and FIND_ONLY_NS (defined in |
| ︙ | ︙ | |||
307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
/* Next in list of all active command
* traces for the interpreter, or NULL
* if no more. */
CommandTrace *nextTracePtr; /* Next trace to check after current
* trace procedure returns; if this
* trace gets deleted, must update pointer
* to avoid using free'd memory. */
} ActiveCommandTrace;
/*
* When a variable trace is active (i.e. its associated procedure is
* executing), one of the following structures is linked into a list
* associated with the variable's interpreter. The information in
* the structure is needed in order for Tcl to behave reasonably
| > > | 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
/* Next in list of all active command
* traces for the interpreter, or NULL
* if no more. */
CommandTrace *nextTracePtr; /* Next trace to check after current
* trace procedure returns; if this
* trace gets deleted, must update pointer
* to avoid using free'd memory. */
int reverseScan; /* Boolean set true when the traces
* are scanning in reverse order. */
} ActiveCommandTrace;
/*
* When a variable trace is active (i.e. its associated procedure is
* executing), one of the following structures is linked into a list
* associated with the variable's interpreter. The information in
* the structure is needed in order for Tcl to behave reasonably
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 687 688 689 690 691 692 693 |
/* Next in list of all active command
* traces for the interpreter, or NULL
* if no more. */
Trace *nextTracePtr; /* Next trace to check after current
* trace procedure returns; if this
* trace gets deleted, must update pointer
* to avoid using free'd memory. */
} ActiveInterpTrace;
/*
* The structure below defines an entry in the assocData hash table which
* is associated with an interpreter. The entry contains a pointer to a
* function to call when the interpreter is deleted, and a pointer to
* a user-defined piece of data.
| > > | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
/* Next in list of all active command
* traces for the interpreter, or NULL
* if no more. */
Trace *nextTracePtr; /* Next trace to check after current
* trace procedure returns; if this
* trace gets deleted, must update pointer
* to avoid using free'd memory. */
int reverseScan; /* Boolean set true when the traces
* are scanning in reverse order. */
} ActiveInterpTrace;
/*
* The structure below defines an entry in the assocData hash table which
* is associated with an interpreter. The entry contains a pointer to a
* function to call when the interpreter is deleted, and a pointer to
* a user-defined piece of data.
|
| ︙ | ︙ | |||
753 754 755 756 757 758 759 760 761 762 763 764 765 766 |
int numCompiledLocals; /* Count of local variables recognized by
* the compiler including arguments. */
Var* compiledLocals; /* Points to the array of local variables
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
} CallFrame;
/*
*----------------------------------------------------------------
* Data structures and procedures related to TclHandles, which
* are a very lightweight method of preserving enough information
* to determine if an arbitrary malloc'd block has been deleted.
*----------------------------------------------------------------
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 |
int numCompiledLocals; /* Count of local variables recognized by
* the compiler including arguments. */
Var* compiledLocals; /* Points to the array of local variables
* recognized by the compiler. The compiler
* emits code that refers to these variables
* using an index into this array. */
} CallFrame;
#ifdef TCL_TIP280
/*
* TIP #280
* The structure below defines a command frame. A command frame
* provides location information for all commands executing a tcl
* script (source, eval, uplevel, procedure bodies, ...). The runtime
* structure essentially contains the stack trace as it would be if
* the currently executing command were to throw an error.
*
* For commands where it makes sense it refers to the associated
* CallFrame as well.
*
* The structures are chained in a single list, with the top of the
* stack anchored in the Interp structure.
*
* Instances can be allocated on the C stack, or the heap, the former
* making cleanup a bit simpler.
*/
typedef struct CmdFrame {
/* General data. Always available. */
int type; /* Values see below */
int level; /* #Frames in stack, prevent O(n) scan of list */
int* line; /* Lines the words of the command start on */
int nline;
CallFrame* framePtr; /* Procedure activation record, may be NULL */
struct CmdFrame* nextPtr; /* Link to calling frame */
/* Data needed for Eval vs TEBC
*
* EXECUTION CONTEXTS and usage of CmdFrame
*
* Field TEBC EvalEx EvalObjEx
* ======= ==== ====== =========
* level yes yes yes
* type BC/PREBC SRC/EVAL EVAL_LIST
* line0 yes yes yes
* framePtr yes yes yes
* ======= ==== ====== =========
*
* ======= ==== ====== ========= union data
* line1 - yes -
* line3 - yes -
* path - yes -
* ------- ---- ------ ---------
* codePtr yes - -
* pc yes - -
* ======= ==== ====== =========
*
* ======= ==== ====== ========= | union cmd
* listPtr - - yes |
* ------- ---- ------ --------- |
* cmd yes yes - |
* cmdlen yes yes - |
* ------- ---- ------ --------- |
*/
union {
struct {
Tcl_Obj* path; /* Path of the sourced file the command
* is in. */
} eval;
struct {
CONST void* codePtr; /* Byte code currently executed */
CONST char* pc; /* and instruction pointer. */
} tebc;
} data;
union {
struct {
CONST char* cmd; /* The executed command, if possible */
int len; /* And its length */
} str;
Tcl_Obj* listPtr; /* Tcl_EvalObjEx, cmd list */
} cmd;
} CmdFrame;
/* The following macros define the allowed values for the type field
* of the CmdFrame structure above. Some of the values occur only in
* the extended location data referenced via the 'baseLocPtr'.
*
* TCL_LOCATION_EVAL : Frame is for a script evaluated by EvalEx.
* TCL_LOCATION_EVAL_LIST : Frame is for a script evaluated by the list
* optimization path of EvalObjEx.
* TCL_LOCATION_BC : Frame is for bytecode.
* TCL_LOCATION_PREBC : Frame is for precompiled bytecode.
* TCL_LOCATION_SOURCE : Frame is for a script evaluated by EvalEx,
* from a sourced file.
* TCL_LOCATION_PROC : Frame is for bytecode of a procedure.
*
* A TCL_LOCATION_BC type in a frame can be overridden by _SOURCE and
* _PROC types, per the context of the byte code in execution.
*/
#define TCL_LOCATION_EVAL (0) /* Location in a dynamic eval script */
#define TCL_LOCATION_EVAL_LIST (1) /* Location in a dynamic eval script, list-path */
#define TCL_LOCATION_BC (2) /* Location in byte code */
#define TCL_LOCATION_PREBC (3) /* Location in precompiled byte code, no location */
#define TCL_LOCATION_SOURCE (4) /* Location in a file */
#define TCL_LOCATION_PROC (5) /* Location in a dynamic proc */
#define TCL_LOCATION_LAST (6) /* Number of values in the enum */
#endif
/*
*----------------------------------------------------------------
* Data structures and procedures related to TclHandles, which
* are a very lightweight method of preserving enough information
* to determine if an arbitrary malloc'd block has been deleted.
*----------------------------------------------------------------
|
| ︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 |
/* Procedure handling variable name
* resolution at compile time. */
struct ResolverScheme *nextPtr;
/* Pointer to next record in linked list. */
} ResolverScheme;
/*
*----------------------------------------------------------------
* This structure defines an interpreter, which is a collection of
* commands plus other state information related to interpreting
* commands, such as variable storage. Primary responsibility for
* this data structure is in tclBasic.c, but almost every Tcl
* source file uses something in here.
| > > > > > > > > > > > | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 |
/* Procedure handling variable name
* resolution at compile time. */
struct ResolverScheme *nextPtr;
/* Pointer to next record in linked list. */
} ResolverScheme;
#ifdef TCL_TIP268
/*
* TIP #268.
* Values for the selection mode, i.e the package require preferences.
*/
enum PkgPreferOptions {
PKG_PREFER_LATEST, PKG_PREFER_STABLE
};
#endif
/*
*----------------------------------------------------------------
* This structure defines an interpreter, which is a collection of
* commands plus other state information related to interpreting
* commands, such as variable storage. Primary responsibility for
* this data structure is in tclBasic.c, but almost every Tcl
* source file uses something in here.
|
| ︙ | ︙ | |||
1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 |
ActiveInterpTrace *activeInterpTracePtr;
/* First in list of active traces for
* interp, or NULL if no active traces. */
int tracesForbiddingInline; /* Count of traces (in the list headed by
* tracePtr) that forbid inline bytecode
* compilation */
/*
* Statistical information about the bytecode compiler and interpreter's
* operation.
*/
#ifdef TCL_COMPILE_STATS
ByteCodeStats stats; /* Holds compilation and execution
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 |
ActiveInterpTrace *activeInterpTracePtr;
/* First in list of active traces for
* interp, or NULL if no active traces. */
int tracesForbiddingInline; /* Count of traces (in the list headed by
* tracePtr) that forbid inline bytecode
* compilation */
#ifdef TCL_TIP280
/* TIP #280 */
CmdFrame* cmdFramePtr; /* Points to the command frame containing
* the location information for the current
* command. */
CONST CmdFrame* invokeCmdFramePtr; /* Points to the command frame which is the
* invoking context of the bytecode compiler.
* NULL when the byte code compiler is not
* active */
int invokeWord; /* Index of the word in the command which
* is getting compiled. */
Tcl_HashTable* linePBodyPtr;
/* This table remembers for each
* statically defined procedure the
* location information for its
* body. It is keyed by the address of
* the Proc structure for a procedure.
*/
Tcl_HashTable* lineBCPtr;
/* This table remembers for each
* ByteCode object the location
* information for its body. It is
* keyed by the address of the Proc
* structure for a procedure.
*/
#endif
#ifdef TCL_TIP268
/*
* TIP #268.
* The currently active selection mode,
* i.e the package require preferences.
*/
int packagePrefer; /* Current package selection mode. */
#endif
/*
* Statistical information about the bytecode compiler and interpreter's
* operation.
*/
#ifdef TCL_COMPILE_STATS
ByteCodeStats stats; /* Holds compilation and execution
|
| ︙ | ︙ | |||
1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 | * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with * a code other than TCL_OK or TCL_ERROR; 0 means * codes other than these should be turned into errors. */ #define TCL_BRACKET_TERM 1 #define TCL_ALLOW_EXCEPTIONS 4 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of | > > > > | 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 | * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with * a code other than TCL_OK or TCL_ERROR; 0 means * codes other than these should be turned into errors. */ #define TCL_BRACKET_TERM 1 #define TCL_ALLOW_EXCEPTIONS 4 #ifdef TCL_TIP280 #define TCL_EVAL_FILE 2 #define TCL_EVAL_CTX 8 #endif /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of |
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 | #define ERROR_CODE_SET 8 #define EXPR_INITIALIZED 0x10 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 #define USE_EVAL_DIRECT 0x100 #define INTERP_TRACE_IN_PROGRESS 0x200 | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 | #define ERROR_CODE_SET 8 #define EXPR_INITIALIZED 0x10 #define DONT_COMPILE_CMDS_INLINE 0x20 #define RAND_SEED_INITIALIZED 0x40 #define SAFE_INTERP 0x80 #define USE_EVAL_DIRECT 0x100 #define INTERP_TRACE_IN_PROGRESS 0x200 /* * Maximum number of levels of nesting permitted in Tcl commands (used * to catch infinite recursion). */ #define MAX_NESTING_DEPTH 1000 |
| ︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 |
typedef struct TclFile_ *TclFile;
/*
* Opaque names for platform specific types.
*/
typedef struct TclpTime_t_ *TclpTime_t;
/*
* The "globParameters" argument of the function TclGlob is an
* or'ed combination of the following values:
*/
#define TCL_GLOBMODE_NO_COMPLAIN 1
| > | 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 |
typedef struct TclFile_ *TclFile;
/*
* Opaque names for platform specific types.
*/
typedef struct TclpTime_t_ *TclpTime_t;
typedef struct TclpTime_t_ *CONST TclpTime_t_CONST;
/*
* The "globParameters" argument of the function TclGlob is an
* or'ed combination of the following values:
*/
#define TCL_GLOBMODE_NO_COMPLAIN 1
|
| ︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 | extern int tclBlockTimeSet; extern char * tclExecutableName; extern char * tclNativeExecutableName; extern char * tclDefaultEncodingDir; extern Tcl_ChannelType tclFileChannelType; extern char * tclMemDumpFileName; extern TclPlatformType tclPlatform; /* * Variables denoting the Tcl object types defined in the core. */ extern Tcl_ObjType tclBooleanType; extern Tcl_ObjType tclByteArrayType; extern Tcl_ObjType tclByteCodeType; extern Tcl_ObjType tclDoubleType; extern Tcl_ObjType tclEndOffsetType; extern Tcl_ObjType tclIntType; extern Tcl_ObjType tclListType; extern Tcl_ObjType tclProcBodyType; extern Tcl_ObjType tclStringType; extern Tcl_ObjType tclArraySearchType; extern Tcl_ObjType tclIndexType; extern Tcl_ObjType tclNsNameType; | > < < | 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 | extern int tclBlockTimeSet; extern char * tclExecutableName; extern char * tclNativeExecutableName; extern char * tclDefaultEncodingDir; extern Tcl_ChannelType tclFileChannelType; extern char * tclMemDumpFileName; extern TclPlatformType tclPlatform; extern Tcl_NotifierProcs tclOriginalNotifier; /* * Variables denoting the Tcl object types defined in the core. */ extern Tcl_ObjType tclBooleanType; extern Tcl_ObjType tclByteArrayType; extern Tcl_ObjType tclByteCodeType; extern Tcl_ObjType tclDoubleType; extern Tcl_ObjType tclEndOffsetType; extern Tcl_ObjType tclIntType; extern Tcl_ObjType tclListType; extern Tcl_ObjType tclProcBodyType; extern Tcl_ObjType tclStringType; extern Tcl_ObjType tclArraySearchType; extern Tcl_ObjType tclIndexType; extern Tcl_ObjType tclNsNameType; extern Tcl_ObjType tclWideIntType; /* * Variables denoting the hash key types defined in the core. */ extern Tcl_HashKeyType tclArrayHashKeyType; extern Tcl_HashKeyType tclOneWordHashKeyType; |
| ︙ | ︙ | |||
1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 | /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside * world: *---------------------------------------------------------------- */ EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj)); EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp, CONST char *value)); EXTERN void TclExpandTokenArray _ANSI_ARGS_(( Tcl_Parse *parsePtr)); EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])) ; EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void)); | > > > > > > > > > > > > > > | > | > > | > > > > | 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 | /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside * world: *---------------------------------------------------------------- */ #ifdef TCL_TIP280 EXTERN void TclAdvanceLines _ANSI_ARGS_((int* line, CONST char* start, CONST char* end)); #endif EXTERN int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj)); EXTERN int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp, CONST char *value)); EXTERN void TclDeleteNamespaceVars _ANSI_ARGS_((Namespace *nsPtr)); #ifdef TCL_TIP280 EXTERN int TclEvalObjEx _ANSI_ARGS_((Tcl_Interp *interp, register Tcl_Obj *objPtr, int flags, CONST CmdFrame* invoker, int word)); #endif EXTERN void TclExpandTokenArray _ANSI_ARGS_(( Tcl_Parse *parsePtr)); EXTERN int TclFileAttrsCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileCopyCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileDeleteCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])) ; EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])) ; EXTERN void TclFinalizeAllocSubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeAsync _ANSI_ARGS_((void)); EXTERN void TclFinalizeCompilation _ANSI_ARGS_((void)); EXTERN void TclFinalizeEncodingSubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void)); EXTERN void TclFinalizeExecution _ANSI_ARGS_((void)); EXTERN void TclFinalizeIOSubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeFilesystem _ANSI_ARGS_((void)); EXTERN void TclResetFilesystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeLoad _ANSI_ARGS_((void)); EXTERN void TclFinalizeLock _ANSI_ARGS_((void)); EXTERN void TclFinalizeMemorySubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeNotifier _ANSI_ARGS_((void)); EXTERN void TclFinalizeObjects _ANSI_ARGS_((void)); EXTERN void TclFinalizePreserve _ANSI_ARGS_((void)); EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void)); EXTERN void TclFinalizeThreadAlloc _ANSI_ARGS_((void)); EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void)); EXTERN int TclGetEncodingFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr)); #ifdef TCL_TIP280 EXTERN void TclGetSrcInfoForPc _ANSI_ARGS_((CmdFrame* cfPtr)); #endif EXTERN int TclGlob _ANSI_ARGS_((Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData* types)); EXTERN void TclInitAlloc _ANSI_ARGS_((void)); EXTERN void TclInitDbCkalloc _ANSI_ARGS_((void)); EXTERN void TclInitEncodingSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitIOSubsystem _ANSI_ARGS_((void)); |
| ︙ | ︙ | |||
1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 |
int numBytes, int *readPtr, char *dst));
EXTERN int TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes,
Tcl_UniChar *resultPtr));
EXTERN int TclParseInteger _ANSI_ARGS_((CONST char *string,
int numBytes));
EXTERN int TclParseWhiteSpace _ANSI_ARGS_((CONST char *src,
int numBytes, Tcl_Parse *parsePtr, char *typePtr));
EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename,
int mode));
EXTERN int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_StatBuf *buf));
EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
EXTERN Tcl_Obj* TclpTempFileName _ANSI_ARGS_((void));
EXTERN Tcl_Obj* TclNewFSPathObj _ANSI_ARGS_((Tcl_Obj *dirPtr,
CONST char *addStrRep, int len));
EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path));
EXTERN void TclpFinalizeCondition _ANSI_ARGS_((
Tcl_Condition *condPtr));
EXTERN void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
EXTERN void TclpFinalizeThreadData _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
EXTERN void TclpFinalizeThreadDataKey _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
EXTERN char * TclpFindExecutable _ANSI_ARGS_((
CONST char *argv0));
EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name,
int *lengthPtr));
| > > > > > | | 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 |
int numBytes, int *readPtr, char *dst));
EXTERN int TclParseHex _ANSI_ARGS_((CONST char *src, int numBytes,
Tcl_UniChar *resultPtr));
EXTERN int TclParseInteger _ANSI_ARGS_((CONST char *string,
int numBytes));
EXTERN int TclParseWhiteSpace _ANSI_ARGS_((CONST char *src,
int numBytes, Tcl_Parse *parsePtr, char *typePtr));
#ifdef TCL_TIP280
EXTERN int TclWordKnownAtCompileTime _ANSI_ARGS_((Tcl_Token* token));
#endif
EXTERN int TclpObjAccess _ANSI_ARGS_((Tcl_Obj *filename,
int mode));
EXTERN int TclpObjLstat _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_StatBuf *buf));
EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
EXTERN Tcl_Obj* TclpTempFileName _ANSI_ARGS_((void));
EXTERN Tcl_Obj* TclNewFSPathObj _ANSI_ARGS_((Tcl_Obj *dirPtr,
CONST char *addStrRep, int len));
EXTERN int TclpDeleteFile _ANSI_ARGS_((CONST char *path));
EXTERN void TclpFinalizeCondition _ANSI_ARGS_((
Tcl_Condition *condPtr));
EXTERN void TclpFinalizeMutex _ANSI_ARGS_((Tcl_Mutex *mutexPtr));
EXTERN void TclpFinalizePipes _ANSI_ARGS_((void));
EXTERN void TclpFinalizeSockets _ANSI_ARGS_((void));
EXTERN void TclpFinalizeThreadData _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
EXTERN void TclpFinalizeThreadDataKey _ANSI_ARGS_((
Tcl_ThreadDataKey *keyPtr));
EXTERN char * TclpFindExecutable _ANSI_ARGS_((
CONST char *argv0));
EXTERN int TclpFindVariable _ANSI_ARGS_((CONST char *name,
int *lengthPtr));
EXTERN int TclpInitLibraryPath _ANSI_ARGS_((CONST char *argv0));
EXTERN void TclpInitLock _ANSI_ARGS_((void));
EXTERN void TclpInitPlatform _ANSI_ARGS_((void));
EXTERN void TclpInitUnlock _ANSI_ARGS_((void));
EXTERN int TclpLoadFile _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr,
CONST char *sym1, CONST char *sym2,
Tcl_PackageInitProc **proc1Ptr,
|
| ︙ | ︙ | |||
1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 | int recursive, Tcl_Obj **errorPtr)); EXTERN int TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)); EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)); EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType)); EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr)); EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj*pathPtr)); EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions)); | > < < > > > > > | 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 | int recursive, Tcl_Obj **errorPtr)); EXTERN int TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)); EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)); EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN Tcl_FSDupInternalRepProc TclNativeDupInternalRep; EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType)); EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr)); EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj*pathPtr)); EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions)); EXTERN void TclpPanic _ANSI_ARGS_(TCL_VARARGS(CONST char *, format)); EXTERN char * TclpReadlink _ANSI_ARGS_((CONST char *fileName, Tcl_DString *linkPtr)); EXTERN void TclpReleaseFile _ANSI_ARGS_((TclFile file)); EXTERN void TclpSetVariables _ANSI_ARGS_((Tcl_Interp *interp)); EXTERN void TclpUnloadFile _ANSI_ARGS_((Tcl_LoadHandle loadHandle)); EXTERN VOID * TclpThreadDataKeyGet _ANSI_ARGS_(( Tcl_ThreadDataKey *keyPtr)); EXTERN void TclpThreadDataKeyInit _ANSI_ARGS_(( Tcl_ThreadDataKey *keyPtr)); EXTERN void TclpThreadDataKeySet _ANSI_ARGS_(( Tcl_ThreadDataKey *keyPtr, VOID *data)); EXTERN int TclpThreadCreate _ANSI_ARGS_(( Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags)); EXTERN void TclpThreadExit _ANSI_ARGS_((int status)); EXTERN void TclRememberCondition _ANSI_ARGS_((Tcl_Condition *mutex)); EXTERN void TclRememberDataKey _ANSI_ARGS_((Tcl_ThreadDataKey *mutex)); EXTERN VOID TclRememberJoinableThread _ANSI_ARGS_((Tcl_ThreadId id)); EXTERN void TclRememberMutex _ANSI_ARGS_((Tcl_Mutex *mutex)); EXTERN VOID TclSignalExitThread _ANSI_ARGS_((Tcl_ThreadId id, int result)); |
| ︙ | ︙ | |||
1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 | Tcl_LoadHandle loadHandle, CONST char *symbol)); EXTERN int TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr)); EXTERN int TclpUtime _ANSI_ARGS_((Tcl_Obj *pathPtr, struct utimbuf *tval)); /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- */ | > > > > > > > > > | 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 | Tcl_LoadHandle loadHandle, CONST char *symbol)); EXTERN int TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr)); EXTERN int TclpUtime _ANSI_ARGS_((Tcl_Obj *pathPtr, struct utimbuf *tval)); #ifdef TCL_LOAD_FROM_MEMORY EXTERN void* TclpLoadMemoryGetBuffer _ANSI_ARGS_(( Tcl_Interp *interp, int size)); EXTERN int TclpLoadMemory _ANSI_ARGS_((Tcl_Interp *interp, void *buffer, int size, int codeSize, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr)); #endif /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
2103 2104 2105 2106 2107 2108 2109 |
TclAllocObjStorage(objPtr); \
TclIncrObjsAllocated(); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL
| > > | > > > > | 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 |
TclAllocObjStorage(objPtr); \
TclIncrObjsAllocated(); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL
#ifdef TCL_MEM_DEBUG
# define TclDecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
#else
# define TclDecrRefCount(objPtr) \
if (--(objPtr)->refCount <= 0) { \
if (((objPtr)->typePtr != NULL) \
&& ((objPtr)->typePtr->freeIntRepProc != NULL)) { \
(objPtr)->typePtr->freeIntRepProc(objPtr); \
} \
if (((objPtr)->bytes != NULL) \
&& ((objPtr)->bytes != tclEmptyStringRep)) { \
ckfree((char *) (objPtr)->bytes); \
} \
TclFreeObjStorage(objPtr); \
TclIncrObjsFreed(); \
}
#endif
#ifdef TCL_MEM_DEBUG
# define TclAllocObjStorage(objPtr) \
(objPtr) = (Tcl_Obj *) \
Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__)
# define TclFreeObjStorage(objPtr) \
|
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 |
/*
* The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's
* from per-thread caches.
*/
EXTERN Tcl_Obj *TclThreadAllocObj _ANSI_ARGS_((void));
EXTERN void TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *));
# define TclAllocObjStorage(objPtr) \
(objPtr) = TclThreadAllocObj()
# define TclFreeObjStorage(objPtr) \
TclThreadFreeObj((objPtr))
| > > > > | 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 |
/*
* The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's
* from per-thread caches.
*/
EXTERN Tcl_Obj *TclThreadAllocObj _ANSI_ARGS_((void));
EXTERN void TclThreadFreeObj _ANSI_ARGS_((Tcl_Obj *));
EXTERN void TclFreeAllocCache _ANSI_ARGS_((void *));
EXTERN void TclpFreeAllocMutex _ANSI_ARGS_((Tcl_Mutex* mutex));
EXTERN void TclpFreeAllocCache _ANSI_ARGS_((void *));
# define TclAllocObjStorage(objPtr) \
(objPtr) = TclThreadAllocObj()
# define TclFreeObjStorage(objPtr) \
TclThreadFreeObj((objPtr))
|
| ︙ | ︙ | |||
2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 |
* EXTERN char * TclGetString _ANSI_ARGS_((Tcl_Obj *objPtr));
*----------------------------------------------------------------
*/
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
/*
*----------------------------------------------------------------
* Macro used by the Tcl core get a unicode char from a utf string.
* It checks to see if we have a one-byte utf char before calling
* the real Tcl_UtfToUniChar, as this will save a lot of time for
* primarily ascii string handling. The macro's expression result
* is 1 for the 1-byte case or the result of Tcl_UtfToUniChar.
| > > > > > > > > > > > > > > > > > > > > | 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 |
* EXTERN char * TclGetString _ANSI_ARGS_((Tcl_Obj *objPtr));
*----------------------------------------------------------------
*/
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get a Tcl_WideInt value out of
* a Tcl_Obj of the "wideInt" type. Different implementation on
* different platforms depending whether TCL_WIDE_INT_IS_LONG.
*----------------------------------------------------------------
*/
#ifdef TCL_WIDE_INT_IS_LONG
# define TclGetWide(resultVar, objPtr) \
(resultVar) = (objPtr)->internalRep.longValue
# define TclGetLongFromWide(resultVar, objPtr) \
(resultVar) = (objPtr)->internalRep.longValue
#else
# define TclGetWide(resultVar, objPtr) \
(resultVar) = (objPtr)->internalRep.wideValue
# define TclGetLongFromWide(resultVar, objPtr) \
(resultVar) = Tcl_WideAsLong((objPtr)->internalRep.wideValue)
#endif
/*
*----------------------------------------------------------------
* Macro used by the Tcl core get a unicode char from a utf string.
* It checks to see if we have a one-byte utf char before calling
* the real Tcl_UtfToUniChar, as this will save a lot of time for
* primarily ascii string handling. The macro's expression result
* is 1 for the 1-byte case or the result of Tcl_UtfToUniChar.
|
| ︙ | ︙ |
Changes to generic/tclIntDecls.h.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclIntDecls.h -- * * This file contains the declarations for all unsupported * functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclIntDecls.h -- * * This file contains the declarations for all unsupported * functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclIntDecls.h,v 1.49.2.9 2007/04/21 19:52:14 kennykb Exp $ */ #ifndef _TCLINTDECLS #define _TCLINTDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl |
| ︙ | ︙ | |||
111 112 113 114 115 116 117 | CONST char * procName)); /* 24 */ EXTERN int TclFormatInt _ANSI_ARGS_((char * buffer, long n)); /* 25 */ EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr)); /* Slot 26 is reserved */ /* 27 */ | | | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | CONST char * procName)); /* 24 */ EXTERN int TclFormatInt _ANSI_ARGS_((char * buffer, long n)); /* 25 */ EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr)); /* Slot 26 is reserved */ /* 27 */ EXTERN int TclGetDate _ANSI_ARGS_((char * p, Tcl_WideInt now, long zone, Tcl_WideInt * timePtr)); /* 28 */ EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); /* Slot 29 is reserved */ /* Slot 30 is reserved */ /* 31 */ EXTERN char * TclGetExtension _ANSI_ARGS_((char * name)); /* 32 */ |
| ︙ | ︙ | |||
237 238 239 240 241 242 243 | /* 75 */ EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); /* 76 */ EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); /* 77 */ EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time * time)); /* 78 */ | | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 | /* 75 */ EXTERN unsigned long TclpGetClicks _ANSI_ARGS_((void)); /* 76 */ EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void)); /* 77 */ EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time * time)); /* 78 */ EXTERN int TclpGetTimeZone _ANSI_ARGS_((Tcl_WideInt time)); /* Slot 79 is reserved */ /* Slot 80 is reserved */ /* 81 */ EXTERN char * TclpRealloc _ANSI_ARGS_((char * ptr, unsigned int size)); /* Slot 82 is reserved */ /* Slot 83 is reserved */ |
| ︙ | ︙ | |||
499 500 501 502 503 504 505 506 507 508 509 510 511 512 |
/* 172 */
EXTERN int TclInThreadExit _ANSI_ARGS_((void));
/* 173 */
EXTERN int TclUniCharMatch _ANSI_ARGS_((
CONST Tcl_UniChar * string, int strLen,
CONST Tcl_UniChar * pattern, int ptnLen,
int nocase));
typedef struct TclIntStubs {
int magic;
struct TclIntStubHooks *hooks;
void *reserved0;
int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 |
/* 172 */
EXTERN int TclInThreadExit _ANSI_ARGS_((void));
/* 173 */
EXTERN int TclUniCharMatch _ANSI_ARGS_((
CONST Tcl_UniChar * string, int strLen,
CONST Tcl_UniChar * pattern, int ptnLen,
int nocase));
/* Slot 174 is reserved */
/* Slot 175 is reserved */
/* Slot 176 is reserved */
/* Slot 177 is reserved */
/* Slot 178 is reserved */
/* Slot 179 is reserved */
/* Slot 180 is reserved */
/* Slot 181 is reserved */
/* 182 */
EXTERN struct tm * TclpLocaltime _ANSI_ARGS_((TclpTime_t_CONST clock));
/* 183 */
EXTERN struct tm * TclpGmtime _ANSI_ARGS_((TclpTime_t_CONST clock));
/* Slot 184 is reserved */
/* Slot 185 is reserved */
/* Slot 186 is reserved */
/* Slot 187 is reserved */
/* Slot 188 is reserved */
/* Slot 189 is reserved */
/* Slot 190 is reserved */
/* Slot 191 is reserved */
/* Slot 192 is reserved */
/* Slot 193 is reserved */
/* Slot 194 is reserved */
/* Slot 195 is reserved */
/* Slot 196 is reserved */
/* Slot 197 is reserved */
/* Slot 198 is reserved */
/* 199 */
EXTERN int TclMatchIsTrivial _ANSI_ARGS_((CONST char * pattern));
typedef struct TclIntStubs {
int magic;
struct TclIntStubHooks *hooks;
void *reserved0;
int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
void *reserved20;
void *reserved21;
int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */
int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */
void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */
void *reserved26;
| | | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
void *reserved20;
void *reserved21;
int (*tclFindElement) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int listLength, CONST char ** elementPtr, CONST char ** nextPtr, int * sizePtr, int * bracePtr)); /* 22 */
Proc * (*tclFindProc) _ANSI_ARGS_((Interp * iPtr, CONST char * procName)); /* 23 */
int (*tclFormatInt) _ANSI_ARGS_((char * buffer, long n)); /* 24 */
void (*tclFreePackageInfo) _ANSI_ARGS_((Interp * iPtr)); /* 25 */
void *reserved26;
int (*tclGetDate) _ANSI_ARGS_((char * p, Tcl_WideInt now, long zone, Tcl_WideInt * timePtr)); /* 27 */
Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
void *reserved29;
void *reserved30;
char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CallFrame ** framePtrPtr)); /* 32 */
TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
void *reserved71;
void *reserved72;
void *reserved73;
void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */
unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */
unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */
void (*tclpGetTime) _ANSI_ARGS_((Tcl_Time * time)); /* 77 */
| | | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
void *reserved71;
void *reserved72;
void *reserved73;
void (*tclpFree) _ANSI_ARGS_((char * ptr)); /* 74 */
unsigned long (*tclpGetClicks) _ANSI_ARGS_((void)); /* 75 */
unsigned long (*tclpGetSeconds) _ANSI_ARGS_((void)); /* 76 */
void (*tclpGetTime) _ANSI_ARGS_((Tcl_Time * time)); /* 77 */
int (*tclpGetTimeZone) _ANSI_ARGS_((Tcl_WideInt time)); /* 78 */
void *reserved79;
void *reserved80;
char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */
void *reserved82;
void *reserved83;
void *reserved84;
void *reserved85;
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 709 710 711 712 713 714 715 |
void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */
Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */
int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */
int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */
int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */
int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */
int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */
} TclIntStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
| > > > > > > > > > > > > > > > > > > > > > > > > > > | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
void (*tclSetStartupScriptPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 167 */
Tcl_Obj * (*tclGetStartupScriptPath) _ANSI_ARGS_((void)); /* 168 */
int (*tclpUtfNcmp2) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 169 */
int (*tclCheckInterpTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 170 */
int (*tclCheckExecutionTraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command, int numChars, Command * cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *CONST objv[])); /* 171 */
int (*tclInThreadExit) _ANSI_ARGS_((void)); /* 172 */
int (*tclUniCharMatch) _ANSI_ARGS_((CONST Tcl_UniChar * string, int strLen, CONST Tcl_UniChar * pattern, int ptnLen, int nocase)); /* 173 */
void *reserved174;
void *reserved175;
void *reserved176;
void *reserved177;
void *reserved178;
void *reserved179;
void *reserved180;
void *reserved181;
struct tm * (*tclpLocaltime) _ANSI_ARGS_((TclpTime_t_CONST clock)); /* 182 */
struct tm * (*tclpGmtime) _ANSI_ARGS_((TclpTime_t_CONST clock)); /* 183 */
void *reserved184;
void *reserved185;
void *reserved186;
void *reserved187;
void *reserved188;
void *reserved189;
void *reserved190;
void *reserved191;
void *reserved192;
void *reserved193;
void *reserved194;
void *reserved195;
void *reserved196;
void *reserved197;
void *reserved198;
int (*tclMatchIsTrivial) _ANSI_ARGS_((CONST char * pattern)); /* 199 */
} TclIntStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
|
| ︙ | ︙ | |||
1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 | #define TclInThreadExit \ (tclIntStubsPtr->tclInThreadExit) /* 172 */ #endif #ifndef TclUniCharMatch #define TclUniCharMatch \ (tclIntStubsPtr->tclUniCharMatch) /* 173 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLINTDECLS */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 | #define TclInThreadExit \ (tclIntStubsPtr->tclInThreadExit) /* 172 */ #endif #ifndef TclUniCharMatch #define TclUniCharMatch \ (tclIntStubsPtr->tclUniCharMatch) /* 173 */ #endif /* Slot 174 is reserved */ /* Slot 175 is reserved */ /* Slot 176 is reserved */ /* Slot 177 is reserved */ /* Slot 178 is reserved */ /* Slot 179 is reserved */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ #ifndef TclpLocaltime #define TclpLocaltime \ (tclIntStubsPtr->tclpLocaltime) /* 182 */ #endif #ifndef TclpGmtime #define TclpGmtime \ (tclIntStubsPtr->tclpGmtime) /* 183 */ #endif /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ /* Slot 189 is reserved */ /* Slot 190 is reserved */ /* Slot 191 is reserved */ /* Slot 192 is reserved */ /* Slot 193 is reserved */ /* Slot 194 is reserved */ /* Slot 195 is reserved */ /* Slot 196 is reserved */ /* Slot 197 is reserved */ /* Slot 198 is reserved */ #ifndef TclMatchIsTrivial #define TclMatchIsTrivial \ (tclIntStubsPtr->tclMatchIsTrivial) /* 199 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLINTDECLS */ |
Changes to generic/tclIntPlatDecls.h.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclIntPlatDecls.h -- * * This file contains the declarations for all platform dependent * unsupported functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclIntPlatDecls.h -- * * This file contains the declarations for all platform dependent * unsupported functions that are exported by the Tcl library. These * interfaces are not guaranteed to remain the same between * versions. Use at your own risk. * * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * * RCS: @(#) $Id: tclIntPlatDecls.h,v 1.19.2.7 2007/04/21 19:52:14 kennykb Exp $ */ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | int timeout)); /* 9 */ EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_(( CONST char * contents)); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir _ANSI_ARGS_((DIR * dir)); /* 11 */ | | > | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | int timeout)); /* 9 */ EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_(( CONST char * contents)); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir _ANSI_ARGS_((DIR * dir)); /* 11 */ EXTERN struct tm * TclpLocaltime_unix _ANSI_ARGS_(( TclpTime_t_CONST clock)); /* 12 */ EXTERN struct tm * TclpGmtime_unix _ANSI_ARGS_((TclpTime_t_CONST clock)); /* 13 */ EXTERN char * TclpInetNtoa _ANSI_ARGS_((struct in_addr addr)); #endif /* UNIX */ #ifdef __WIN32__ /* 0 */ EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode)); /* 1 */ |
| ︙ | ︙ | |||
135 136 137 138 139 140 141 142 143 144 145 146 147 148 | EXTERN TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void)); /* 26 */ EXTERN void TclWinSetInterfaces _ANSI_ARGS_((int wide)); /* 27 */ EXTERN void TclWinFlushDirtyChannels _ANSI_ARGS_((void)); /* 28 */ EXTERN void TclWinResetInterfaces _ANSI_ARGS_((void)); #endif /* __WIN32__ */ #ifdef MAC_TCL /* 0 */ EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); /* 1 */ EXTERN void TclpSysFree _ANSI_ARGS_((VOID * ptr)); /* 2 */ | > > > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | EXTERN TclPlatformType * TclWinGetPlatform _ANSI_ARGS_((void)); /* 26 */ EXTERN void TclWinSetInterfaces _ANSI_ARGS_((int wide)); /* 27 */ EXTERN void TclWinFlushDirtyChannels _ANSI_ARGS_((void)); /* 28 */ EXTERN void TclWinResetInterfaces _ANSI_ARGS_((void)); /* 29 */ EXTERN int TclWinCPUID _ANSI_ARGS_((unsigned int index, unsigned int * regs)); #endif /* __WIN32__ */ #ifdef MAC_TCL /* 0 */ EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin)); /* 1 */ EXTERN void TclpSysFree _ANSI_ARGS_((VOID * ptr)); /* 2 */ |
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */
void *reserved5;
TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */
TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */
int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */
TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */
Tcl_DirEntry * (*tclpReaddir) _ANSI_ARGS_((DIR * dir)); /* 10 */
| | | | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
int (*tclpCreateProcess) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid * pidPtr)); /* 4 */
void *reserved5;
TclFile (*tclpMakeFile) _ANSI_ARGS_((Tcl_Channel channel, int direction)); /* 6 */
TclFile (*tclpOpenFile) _ANSI_ARGS_((CONST char * fname, int mode)); /* 7 */
int (*tclUnixWaitForFile) _ANSI_ARGS_((int fd, int mask, int timeout)); /* 8 */
TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 9 */
Tcl_DirEntry * (*tclpReaddir) _ANSI_ARGS_((DIR * dir)); /* 10 */
struct tm * (*tclpLocaltime_unix) _ANSI_ARGS_((TclpTime_t_CONST clock)); /* 11 */
struct tm * (*tclpGmtime_unix) _ANSI_ARGS_((TclpTime_t_CONST clock)); /* 12 */
char * (*tclpInetNtoa) _ANSI_ARGS_((struct in_addr addr)); /* 13 */
#endif /* UNIX */
#ifdef __WIN32__
void (*tclWinConvertError) _ANSI_ARGS_((DWORD errCode)); /* 0 */
void (*tclWinConvertWSAError) _ANSI_ARGS_((DWORD errCode)); /* 1 */
struct servent * (*tclWinGetServByName) _ANSI_ARGS_((CONST char * nm, CONST char * proto)); /* 2 */
int (*tclWinGetSockOpt) _ANSI_ARGS_((SOCKET s, int level, int optname, char FAR * optval, int FAR * optlen)); /* 3 */
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */
char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */
char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */
TclPlatformType * (*tclWinGetPlatform) _ANSI_ARGS_((void)); /* 25 */
void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */
void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */
void (*tclWinResetInterfaces) _ANSI_ARGS_((void)); /* 28 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
VOID * (*tclpSysAlloc) _ANSI_ARGS_((long size, int isBin)); /* 0 */
void (*tclpSysFree) _ANSI_ARGS_((VOID * ptr)); /* 1 */
VOID * (*tclpSysRealloc) _ANSI_ARGS_((VOID * cp, unsigned int size)); /* 2 */
void (*tclpExit) _ANSI_ARGS_((int status)); /* 3 */
int (*fSpGetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 4 */
| > | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
TclFile (*tclpCreateTempFile) _ANSI_ARGS_((CONST char * contents)); /* 22 */
char * (*tclpGetTZName) _ANSI_ARGS_((int isdst)); /* 23 */
char * (*tclWinNoBackslash) _ANSI_ARGS_((char * path)); /* 24 */
TclPlatformType * (*tclWinGetPlatform) _ANSI_ARGS_((void)); /* 25 */
void (*tclWinSetInterfaces) _ANSI_ARGS_((int wide)); /* 26 */
void (*tclWinFlushDirtyChannels) _ANSI_ARGS_((void)); /* 27 */
void (*tclWinResetInterfaces) _ANSI_ARGS_((void)); /* 28 */
int (*tclWinCPUID) _ANSI_ARGS_((unsigned int index, unsigned int * regs)); /* 29 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
VOID * (*tclpSysAlloc) _ANSI_ARGS_((long size, int isBin)); /* 0 */
void (*tclpSysFree) _ANSI_ARGS_((VOID * ptr)); /* 1 */
VOID * (*tclpSysRealloc) _ANSI_ARGS_((VOID * cp, unsigned int size)); /* 2 */
void (*tclpExit) _ANSI_ARGS_((int status)); /* 3 */
int (*fSpGetDefaultDir) _ANSI_ARGS_((FSSpecPtr theSpec)); /* 4 */
|
| ︙ | ︙ | |||
347 348 349 350 351 352 353 | #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #endif #ifndef TclpReaddir #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #endif | | | | | | | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 | #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #endif #ifndef TclpReaddir #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #endif #ifndef TclpLocaltime_unix #define TclpLocaltime_unix \ (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ #endif #ifndef TclpGmtime_unix #define TclpGmtime_unix \ (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ #endif #ifndef TclpInetNtoa #define TclpInetNtoa \ (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #endif #endif /* UNIX */ #ifdef __WIN32__ |
| ︙ | ︙ | |||
462 463 464 465 466 467 468 469 470 471 472 473 474 475 | #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ #endif #ifndef TclWinResetInterfaces #define TclWinResetInterfaces \ (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #endif #endif /* __WIN32__ */ #ifdef MAC_TCL #ifndef TclpSysAlloc #define TclpSysAlloc \ (tclIntPlatStubsPtr->tclpSysAlloc) /* 0 */ #endif #ifndef TclpSysFree | > > > > | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 | #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ #endif #ifndef TclWinResetInterfaces #define TclWinResetInterfaces \ (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #endif #ifndef TclWinCPUID #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #endif #endif /* __WIN32__ */ #ifdef MAC_TCL #ifndef TclpSysAlloc #define TclpSysAlloc \ (tclIntPlatStubsPtr->tclpSysAlloc) /* 0 */ #endif #ifndef TclpSysFree |
| ︙ | ︙ |
Changes to generic/tclInterp.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclInterp.c -- * * This file implements the "interp" command which allows creation * and manipulation of Tcl interpreters from within Tcl scripts. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclInterp.c -- * * This file implements the "interp" command which allows creation * and manipulation of Tcl interpreters from within Tcl scripts. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclInterp.c,v 1.20.2.3 2006/11/28 22:20:02 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclPort.h" #include <stdio.h> /* |
| ︙ | ︙ | |||
457 458 459 460 461 462 463 |
i++;
last = 1;
}
if (slavePtr != NULL) {
Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
return TCL_ERROR;
}
| > | > | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
i++;
last = 1;
}
if (slavePtr != NULL) {
Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
return TCL_ERROR;
}
if (i < objc) {
slavePtr = objv[i];
}
}
buf[0] = '\0';
if (slavePtr == NULL) {
/*
* Create an anonymous interpreter -- we choose its name and
* the name of the command. We check that the command name
* that we use for the interpreter does not collide with an
|
| ︙ | ︙ | |||
1440 1441 1442 1443 1444 1445 1446 |
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
Tcl_Interp *targetInterp;
Alias *aliasPtr;
| | | 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 |
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
Tcl_Interp *targetInterp;
Alias *aliasPtr;
int result, prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
aliasPtr = (Alias *) clientData;
targetInterp = aliasPtr->targetInterp;
/*
* Append the arguments to the command prefix and invoke the command
|
| ︙ | ︙ | |||
1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 |
memcpy((VOID *) cmdv, (VOID *) prefv,
(size_t) (prefc * sizeof(Tcl_Obj *)));
memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1),
(size_t) ((objc-1) * sizeof(Tcl_Obj *)));
Tcl_ResetResult(targetInterp);
if (targetInterp != interp) {
Tcl_Preserve((ClientData) targetInterp);
result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
TclTransferResult(targetInterp, result, interp);
Tcl_Release((ClientData) targetInterp);
} else {
result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
}
if (cmdv != cmdArr) {
ckfree((char *) cmdv);
}
return result;
#undef ALIAS_CMDV_PREALLOC
| > > > > > > | 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 |
memcpy((VOID *) cmdv, (VOID *) prefv,
(size_t) (prefc * sizeof(Tcl_Obj *)));
memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1),
(size_t) ((objc-1) * sizeof(Tcl_Obj *)));
Tcl_ResetResult(targetInterp);
for (i=0; i<cmdc; i++) {
Tcl_IncrRefCount(cmdv[i]);
}
if (targetInterp != interp) {
Tcl_Preserve((ClientData) targetInterp);
result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
TclTransferResult(targetInterp, result, interp);
Tcl_Release((ClientData) targetInterp);
} else {
result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE);
}
for (i=0; i<cmdc; i++) {
Tcl_DecrRefCount(cmdv[i]);
}
if (cmdv != cmdArr) {
ckfree((char *) cmdv);
}
return result;
#undef ALIAS_CMDV_PREALLOC
|
| ︙ | ︙ | |||
2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 |
int result;
Tcl_Obj *objPtr;
Tcl_Preserve((ClientData) slaveInterp);
Tcl_AllowExceptions(slaveInterp);
if (objc == 1) {
result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
} else {
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
}
TclTransferResult(slaveInterp, result, interp);
| > > > > > > | 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 |
int result;
Tcl_Obj *objPtr;
Tcl_Preserve((ClientData) slaveInterp);
Tcl_AllowExceptions(slaveInterp);
if (objc == 1) {
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(slaveInterp, objv[0], 0);
#else
/* TIP #280 : Make invoker available to eval'd script */
Interp* iPtr = (Interp*) interp;
result = TclEvalObjEx(slaveInterp, objv[0], 0, iPtr->cmdFramePtr,0);
#endif
} else {
objPtr = Tcl_ConcatObj(objc, objv);
Tcl_IncrRefCount(objPtr);
result = Tcl_EvalObjEx(slaveInterp, objPtr, 0);
Tcl_DecrRefCount(objPtr);
}
TclTransferResult(slaveInterp, result, interp);
|
| ︙ | ︙ |
Changes to generic/tclLink.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclLink.c,v 1.8.2.2 2007/05/10 18:23:58 dgp Exp $ */ #include "tclInt.h" /* * For each linked variable there is a data structure of the following * type, which describes the link and is the clientData for the trace |
| ︙ | ︙ | |||
91 92 93 94 95 96 97 |
CONST char *varName; /* Name of a global variable in interp. */
char *addr; /* Address of a C variable to be linked
* to varName. */
int type; /* Type of C variable: TCL_LINK_INT, etc.
* Also may have TCL_LINK_READ_ONLY
* OR'ed in. */
{
| | > | | | > | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
CONST char *varName; /* Name of a global variable in interp. */
char *addr; /* Address of a C variable to be linked
* to varName. */
int type; /* Type of C variable: TCL_LINK_INT, etc.
* Also may have TCL_LINK_READ_ONLY
* OR'ed in. */
{
Tcl_Obj *objPtr, *resPtr;
Link *linkPtr;
int code;
linkPtr = (Link *) ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
linkPtr->flags = 0;
}
objPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(objPtr);
resPtr = Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(objPtr);
if (resPtr == NULL) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
return TCL_ERROR;
}
code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc,
(ClientData) linkPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
void
Tcl_UpdateLinkedVar(interp, varName)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *varName; /* Name of global variable that is linked. */
{
Link *linkPtr;
int savedFlag;
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
LinkTraceProc, (ClientData) NULL);
if (linkPtr == NULL) {
return;
}
savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
linkPtr->flags |= LINK_BEING_UPDATED;
| > > > | < > | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
void
Tcl_UpdateLinkedVar(interp, varName)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *varName; /* Name of global variable that is linked. */
{
Link *linkPtr;
int savedFlag;
Tcl_Obj *objPtr;
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
LinkTraceProc, (ClientData) NULL);
if (linkPtr == NULL) {
return;
}
savedFlag = linkPtr->flags & LINK_BEING_UPDATED;
linkPtr->flags |= LINK_BEING_UPDATED;
objPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
linkPtr->flags = (linkPtr->flags & ~LINK_BEING_UPDATED) | savedFlag;
}
/*
*----------------------------------------------------------------------
*
* LinkTraceProc --
|
| ︙ | ︙ | |||
233 234 235 236 237 238 239 |
CONST char *name2; /* Second part of variable name. */
int flags; /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *) clientData;
int changed, valueLength;
CONST char *value;
char **pp, *result;
| | | > > | > | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
CONST char *name2; /* Second part of variable name. */
int flags; /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *) clientData;
int changed, valueLength;
CONST char *value;
char **pp, *result;
Tcl_Obj *objPtr, *valueObj, *tmpPtr;
/*
* If the variable is being unset, then just re-create it (with a
* trace) unless the whole interpreter is going away.
*/
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp)) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
}
return NULL;
}
|
| ︙ | ︙ | |||
289 290 291 292 293 294 295 |
case TCL_LINK_STRING:
changed = 1;
break;
default:
return "internal error: bad linked variable type";
}
if (changed) {
| > > | > > > | > > > | > > > | > > > | > > > | > | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
case TCL_LINK_STRING:
changed = 1;
break;
default:
return "internal error: bad linked variable type";
}
if (changed) {
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
}
return NULL;
}
/*
* For writes, first make sure that the variable is writable. Then
* convert the Tcl value to C if possible. If the variable isn't
* writable or can't be converted, then restore the varaible's old
* value and return an error. Another tricky thing: we have to save
* and restore the interpreter's result, since the variable access
* could occur when the result has been partially set.
*/
if (linkPtr->flags & LINK_READ_ONLY) {
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
return "linked variable is read-only";
}
valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
if (valueObj == NULL) {
/*
* This shouldn't ever happen.
*/
return "internal error: linked variable couldn't be read";
}
objPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objPtr);
Tcl_ResetResult(interp);
result = NULL;
switch (linkPtr->type) {
case TCL_LINK_INT:
if (Tcl_GetIntFromObj(interp, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
result = "variable must have integer value";
goto end;
}
*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
if (Tcl_GetWideIntFromObj(interp, valueObj, &linkPtr->lastValue.w)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
result = "variable must have integer value";
goto end;
}
*(Tcl_WideInt *)(linkPtr->addr) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
if (Tcl_GetDoubleFromObj(interp, valueObj, &linkPtr->lastValue.d)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
result = "variable must have real value";
goto end;
}
*(double *)(linkPtr->addr) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
if (Tcl_GetBooleanFromObj(interp, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_SetObjResult(interp, objPtr);
tmpPtr = ObjValue(linkPtr);
Tcl_IncrRefCount(tmpPtr);
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, tmpPtr,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(tmpPtr);
result = "variable must have boolean value";
goto end;
}
*(int *)(linkPtr->addr) = linkPtr->lastValue.i;
break;
case TCL_LINK_STRING:
|
| ︙ | ︙ |
Changes to generic/tclListObj.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclListObj.c -- * * This file contains procedures that implement the Tcl list object * type. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclListObj.c -- * * This file contains procedures that implement the Tcl list object * type. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclListObj.c,v 1.13.4.2 2005/08/25 22:27:08 dkf Exp $ */ #include "tclInt.h" /* * Prototypes for procedures defined later in this file: */ |
| ︙ | ︙ | |||
676 677 678 679 680 681 682 |
start = (first + count);
numAfterLast = (numElems - start);
shift = (objc - count); /* numNewElems - numDeleted */
if ((numAfterLast > 0) && (shift != 0)) {
Tcl_Obj **src, **dst;
| < | < | < < < | < < < | 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
start = (first + count);
numAfterLast = (numElems - start);
shift = (objc - count); /* numNewElems - numDeleted */
if ((numAfterLast > 0) && (shift != 0)) {
Tcl_Obj **src, **dst;
src = elemPtrs + start; dst = src + shift;
memmove((VOID*) dst, (VOID*) src,
(size_t) (numAfterLast * sizeof(Tcl_Obj*)));
}
/*
* Insert the new elements into elemPtrs before "first".
*/
for (i = 0, j = first; i < objc; i++, j++) {
|
| ︙ | ︙ | |||
1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 |
flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int));
}
listPtr->length = 1;
for (i = 0; i < numElems; i++) {
elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length);
listPtr->length += Tcl_ScanCountedElement(elem, length,
&flagPtr[i]) + 1;
}
/*
* Pass 2: copy into string rep buffer.
*/
listPtr->bytes = ckalloc((unsigned) listPtr->length);
| > > > > > > | 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 |
flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int));
}
listPtr->length = 1;
for (i = 0; i < numElems; i++) {
elem = Tcl_GetStringFromObj(listRepPtr->elements[i], &length);
listPtr->length += Tcl_ScanCountedElement(elem, length,
&flagPtr[i]) + 1;
/*
* Check for continued sanity. [Bug 1267380]
*/
if (listPtr->length < 1) {
Tcl_Panic("string representation size exceeds sane bounds");
}
}
/*
* Pass 2: copy into string rep buffer.
*/
listPtr->bytes = ckalloc((unsigned) listPtr->length);
|
| ︙ | ︙ |
Changes to generic/tclMain.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. * * Copyright (c) 1988-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclMain.c -- * * Main program for Tcl shells and other Tcl-based applications. * * Copyright (c) 1988-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMain.c,v 1.20.2.3 2006/05/05 18:08:58 dgp Exp $ */ #include "tcl.h" #include "tclInt.h" # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLEXPORT |
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
char **argv; /* Array of argument strings. */
Tcl_AppInitProc *appInitProc;
/* Application-specific initialization
* procedure to call after most
* initialization but before starting to
* execute commands. */
{
| | < < | < | > < < < < < < < < < < < < | | > > > > | > | > | > > > > > > > > > > > | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
char **argv; /* Array of argument strings. */
Tcl_AppInitProc *appInitProc;
/* Application-specific initialization
* procedure to call after most
* initialization but before starting to
* execute commands. */
{
Tcl_Obj *resultPtr, *argvPtr, *commandPtr = NULL;
PromptType prompt = PROMPT_START;
int code, length, tty, exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
Tcl_Interp *interp;
Tcl_DString appName;
Tcl_Obj *objPtr;
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
Tcl_InitMemory(interp);
/*
* Make command-line arguments available in the Tcl variables "argc"
* and "argv". If the first argument doesn't start with a "-" then
* strip it off and use it as the name of a script file to process.
*/
if (TclGetStartupScriptPath() == NULL) {
if ((argc > 1) && (argv[1][0] != '-')) {
TclSetStartupScriptFileName(argv[1]);
argc--;
argv++;
}
}
if (TclGetStartupScriptPath() == NULL) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
} else {
TclSetStartupScriptFileName(Tcl_ExternalToUtfDString(NULL,
TclGetStartupScriptFileName(), -1, &appName));
}
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&appName);
argc--;
argv++;
objPtr = Tcl_NewIntObj(argc);
Tcl_IncrRefCount(objPtr);
Tcl_SetVar2Ex(interp, "argc", NULL, objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
}
Tcl_IncrRefCount(argvPtr);
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(argvPtr);
/*
* Set the "tcl_interactive" variable.
*/
tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive",
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
NULL, TCL_GLOBAL_ONLY));
Tcl_WriteChars(errChannel, "\n", 1);
}
exitCode = 1;
}
goto done;
}
| < | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
NULL, TCL_GLOBAL_ONLY));
Tcl_WriteChars(errChannel, "\n", 1);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup
* file if the application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
|
| ︙ | ︙ | |||
329 330 331 332 333 334 335 |
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
| > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
while ((inChannel != (Tcl_Channel) NULL) && !Tcl_InterpDeleted(interp)) {
if (mainLoopProc == NULL) {
if (tty) {
Prompt(interp, &prompt);
if (Tcl_InterpDeleted(interp)) {
break;
}
inChannel = Tcl_GetStdChannel(TCL_STDIN);
if (inChannel == (Tcl_Channel) NULL) {
break;
}
}
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(inChannel)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try
* again. This sets up a tight polling loop (since
* we have no event loop running). If this causes
* bad CPU hogging, we might try toggling the blocking
* on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string.
*/
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
prompt = PROMPT_CONTINUE;
continue;
}
prompt = PROMPT_START;
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
} else if (tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively,
* we want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
InteractiveState *isPtr = NULL;
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 499 500 501 502 503 504 505 |
/*
* Rather than calling exit, invoke the "exit" command so that
* users can replace "exit" with some other command to do additional
* cleanup on exit. The Tcl_Eval call should never return.
*/
if (!Tcl_InterpDeleted(interp)) {
sprintf(buffer, "exit %d", exitCode);
Tcl_Eval(interp, buffer);
/*
* If Tcl_Eval returns, trying to eval [exit], something
* unusual is happening. Maybe interp has been deleted;
* maybe [exit] was redefined. We still want to cleanup
| > | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
/*
* Rather than calling exit, invoke the "exit" command so that
* users can replace "exit" with some other command to do additional
* cleanup on exit. The Tcl_Eval call should never return.
*/
if (!Tcl_InterpDeleted(interp)) {
char buffer[TCL_INTEGER_SPACE + 5];
sprintf(buffer, "exit %d", exitCode);
Tcl_Eval(interp, buffer);
/*
* If Tcl_Eval returns, trying to eval [exit], something
* unusual is happening. Maybe interp has been deleted;
* maybe [exit] was redefined. We still want to cleanup
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | * Michael J. McLennan * Bell Labs Innovations for Lucent Technologies * mmclennan@lucent.com * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.14 2007/05/15 18:32:18 dgp Exp $ */ #include "tclInt.h" /* * Flag passed to TclGetNamespaceForQualName to indicate that it should * search for a namespace rather than a command or variable inside a |
| ︙ | ︙ | |||
347 348 349 350 351 352 353 |
void
Tcl_PopCallFrame(interp)
Tcl_Interp* interp; /* Interpreter with call frame to pop. */
{
register Interp *iPtr = (Interp *) interp;
register CallFrame *framePtr = iPtr->framePtr;
| < < < < < < < < < < < < < < < < < < | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
void
Tcl_PopCallFrame(interp)
Tcl_Interp* interp; /* Interpreter with call frame to pop. */
{
register Interp *iPtr = (Interp *) interp;
register CallFrame *framePtr = iPtr->framePtr;
Namespace *nsPtr;
/*
* It's important to remove the call frame from the interpreter's stack
* of call frames before deleting local variables, so that traces
* invoked by the variable deletion don't see the partially-deleted
* frame.
*/
iPtr->framePtr = framePtr->callerPtr;
iPtr->varFramePtr = framePtr->callerVarPtr;
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
ckfree((char *) framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
if (framePtr->numCompiledLocals > 0) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
}
/*
* Decrement the namespace's count of active call frames. If the
* namespace is "dying" and there are no more active call frames,
* call Tcl_DeleteNamespace to destroy it.
*/
nsPtr = framePtr->nsPtr;
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 |
entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
}
nsPtr->parentPtr = NULL;
| | | > > > > | > > > > > > | | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
}
nsPtr->parentPtr = NULL;
} else if (!(nsPtr->flags & NS_KILLED)) {
/*
* Delete the namespace and everything in it. If this is the global
* namespace, then clear it but don't free its storage unless the
* interpreter is being torn down. Set the NS_KILLED flag to avoid
* recursive calls here - if the namespace is really in the process of
* being deleted, ignore any second call.
*/
nsPtr->flags |= (NS_DYING|NS_KILLED);
TclTeardownNamespace(nsPtr);
if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
/*
* If this is the global namespace, then it may have residual
* "errorInfo" and "errorCode" variables for errors that
* occurred while it was being torn down. Try to clear the
* variable list one last time.
*/
TclDeleteNamespaceVars(nsPtr);
Tcl_DeleteHashTable(&nsPtr->childTable);
Tcl_DeleteHashTable(&nsPtr->cmdTable);
/*
* If the reference count is 0, then discard the namespace.
* Otherwise, mark it as "dead" so that it can't be used.
*/
if (nsPtr->refCount == 0) {
NamespaceFree(nsPtr);
} else {
nsPtr->flags |= NS_DEAD;
}
} else {
/*
* We didn't really kill it, so remove the KILLED marks, so
* it can get killed later, avoiding mem leaks
*/
nsPtr->flags &= ~(NS_DYING|NS_KILLED);
}
}
}
/*
*----------------------------------------------------------------------
*
* TclTeardownNamespace --
|
| ︙ | ︙ | |||
709 710 711 712 713 714 715 |
/*
* Start by destroying the namespace's variable table,
* since variables might trigger traces.
*/
if (nsPtr == globalNsPtr) {
/*
| | | < < | > > | | > < < < | < | | < < < < | < | | | | | | | | | | | | | | > > > > > > > > > > > > > > > | 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
/*
* Start by destroying the namespace's variable table,
* since variables might trigger traces.
*/
if (nsPtr == globalNsPtr) {
/*
* This is the global namespace. Tearing it down will destroy the
* ::errorInfo and ::errorCode variables. We save and restore them
* in case there are any errors in progress, so the error details
* they contain will not be lost. See test namespace-8.5
*/
Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo",
NULL, TCL_GLOBAL_ONLY);
Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode",
NULL, TCL_GLOBAL_ONLY);
if (errorInfo) {
Tcl_IncrRefCount(errorInfo);
}
if (errorCode) {
Tcl_IncrRefCount(errorCode);
}
TclDeleteNamespaceVars(nsPtr);
Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
if (errorInfo) {
Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL,
errorInfo, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorInfo);
}
if (errorCode) {
Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL,
errorCode, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorCode);
}
} else {
/*
* Variable table should be cleared but not freed! TclDeleteVars
* frees it, so we reinitialize it afterwards.
*/
TclDeleteNamespaceVars(nsPtr);
Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
}
/*
* Delete all commands in this namespace. Be careful when traversing the
* hash table: when each command is deleted, it removes itself from the
* command table.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
}
Tcl_DeleteHashTable(&nsPtr->cmdTable);
Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
/*
* Remove the namespace from its parent's child hashtable.
*/
if (nsPtr->parentPtr != NULL) {
entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
nsPtr->name);
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
Tcl_DeleteNamespace(childNsPtr);
}
| < < < < < < < < < < < < < < < | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 |
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
Tcl_DeleteNamespace(childNsPtr);
}
/*
* Free the namespace's export pattern array.
*/
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
ckfree(nsPtr->exportArrayPtr[i]);
|
| ︙ | ︙ | |||
904 905 906 907 908 909 910 |
* the current namespace. */
CONST char *pattern; /* String pattern indicating which commands
* to export. This pattern may not include
* any namespace qualifiers; only commands
* in the specified namespace may be
* exported. */
int resetListFirst; /* If nonzero, resets the namespace's
| | < < | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 |
* the current namespace. */
CONST char *pattern; /* String pattern indicating which commands
* to export. This pattern may not include
* any namespace qualifiers; only commands
* in the specified namespace may be
* exported. */
int resetListFirst; /* If nonzero, resets the namespace's
* export list before appending. */
{
#define INIT_EXPORT_PATTERNS 5
Namespace *nsPtr, *exportNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
CONST char *simplePattern;
char *patternCpy;
int neededElems, len, i;
|
| ︙ | ︙ | |||
947 948 949 950 951 952 953 |
}
/*
* Check that the pattern doesn't have namespace qualifiers.
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
| | | | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
}
/*
* Check that the pattern doesn't have namespace qualifiers.
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid export pattern \"", pattern,
"\": pattern can't specify a namespace",
(char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 |
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr, *importNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
CONST char *simplePattern;
char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
| | | 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 |
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr, *importNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
CONST char *simplePattern;
char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Command *cmdPtr;
ImportRef *refPtr;
Tcl_Command autoCmd, importedCmd;
ImportedCmdData *dataPtr;
int wasExported, i, result;
/*
* If the specified namespace is NULL, use the current namespace.
|
| ︙ | ︙ | |||
1175 1176 1177 1178 1179 1180 1181 |
if (strlen(pattern) == 0) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"empty import pattern", -1);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr,
| | | | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
if (strlen(pattern) == 0) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"empty import pattern", -1);
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace in import pattern \"",
pattern, "\"", (char *) NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 |
cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern)) {
/*
* The command cmdName in the source namespace matches the
* pattern. Check whether it was exported. If it wasn't,
* we ignore it.
*/
wasExported = 0;
for (i = 0; i < importNsPtr->numExportPatterns; i++) {
if (Tcl_StringMatch(cmdName,
importNsPtr->exportArrayPtr[i])) {
wasExported = 1;
break;
}
}
if (!wasExported) {
continue;
}
/*
* Unless there is a name clash, create an imported command
* in the current namespace that refers to cmdPtr.
*/
| > | | | | | < > | | > | > > | > | < < > | | | > | | | > | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern)) {
/*
* The command cmdName in the source namespace matches the
* pattern. Check whether it was exported. If it wasn't,
* we ignore it.
*/
Tcl_HashEntry *found;
wasExported = 0;
for (i = 0; i < importNsPtr->numExportPatterns; i++) {
if (Tcl_StringMatch(cmdName,
importNsPtr->exportArrayPtr[i])) {
wasExported = 1;
break;
}
}
if (!wasExported) {
continue;
}
/*
* Unless there is a name clash, create an imported command
* in the current namespace that refers to cmdPtr.
*/
found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
if ((found == NULL) || allowOverwrite) {
/*
* Create the imported command and its client data.
* To create the new command in the current namespace,
* generate a fully qualified name for it.
*/
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
if (nsPtr != iPtr->globalNsPtr) {
Tcl_DStringAppend(&ds, "::", 2);
}
Tcl_DStringAppend(&ds, cmdName, -1);
/*
* Check whether creating the new imported command in the
* current namespace would create a cycle of imported
* command references.
*/
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if ((found != NULL)
&& cmdPtr->deleteProc == DeleteImportedCmd) {
Command *overwrite = (Command *) Tcl_GetHashValue(found);
Command *link = cmdPtr;
while (link->deleteProc == DeleteImportedCmd) {
ImportedCmdData *dataPtr;
dataPtr = (ImportedCmdData *) link->objClientData;
link = dataPtr->realCmdPtr;
if (overwrite == link) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"import pattern \"", pattern,
"\" would create a loop containing ",
"command \"", Tcl_DStringValue(&ds),
"\"", (char *) NULL);
Tcl_DStringFree(&ds);
return TCL_ERROR;
}
}
}
dataPtr = (ImportedCmdData *)
ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_CreateObjCommand(interp,
Tcl_DStringValue(&ds), InvokeImportedCmd,
|
| ︙ | ︙ | |||
1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 |
*/
refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
refPtr->importedCmdPtr = (Command *) importedCmd;
refPtr->nextPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = refPtr;
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't import command \"", cmdName,
"\": already exists", (char *) NULL);
return TCL_ERROR;
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ForgetImport --
*
| > > > > > > > > > > | | > > | | > > > > | < < | < > > | < < < | < | | < | | | > | < > | < < | | | | > > > > | | > > > > > > > > | > > > > | > > > > > > > > | | > | > > | > > > | > | > > > | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 |
*/
refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
refPtr->importedCmdPtr = (Command *) importedCmd;
refPtr->nextPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = refPtr;
} else {
Command *overwrite = (Command *) Tcl_GetHashValue(found);
if (overwrite->deleteProc == DeleteImportedCmd) {
ImportedCmdData *dataPtr =
(ImportedCmdData *) overwrite->objClientData;
if (dataPtr->realCmdPtr
== (Command *) Tcl_GetHashValue(hPtr)) {
/* Repeated import of same command -- acceptable */
return TCL_OK;
}
}
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't import command \"", cmdName,
"\": already exists", (char *) NULL);
return TCL_ERROR;
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ForgetImport --
*
* Deletes commands previously imported into the namespace indicated. The
* by namespacePtr, or the current namespace of interp, when
* namespacePtr is NULL. The pattern controls which imported commands
* are deleted. A simple pattern, one without namespace separators,
* matches the current command names of imported commands in the
* namespace. Matching imported commands are deleted. A qualified
* pattern is interpreted as deletion selection on the basis of where
* the command is imported from. The original command and "first link"
* command for each imported command are determined, and they are matched
* against the pattern. A match leads to deletion of the imported
* command.
*
* Results:
* Returns TCL_ERROR and records an error message in the interp
* result if a namespace qualified pattern refers to a namespace
* that does not exist. Otherwise, returns TCL_OK.
*
* Side effects:
* May delete commands.
*
*----------------------------------------------------------------------
*/
int
Tcl_ForgetImport(interp, namespacePtr, pattern)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Namespace *namespacePtr; /* Points to the namespace from which
* previously imported commands should be
* removed. NULL for current namespace. */
CONST char *pattern; /* String pattern indicating which imported
* commands to remove. */
{
Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
CONST char *simplePattern;
char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* Parse the pattern into its namespace-qualification (if any)
* and the simple pattern.
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace in namespace forget pattern \"",
pattern, "\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(pattern, simplePattern) == 0) {
/*
* The pattern is simple.
* Delete any imported commands that match it.
*/
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
(hPtr != NULL);
hPtr = Tcl_NextHashEntry(&search)) {
Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc != DeleteImportedCmd) {
continue;
}
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
}
}
return TCL_OK;
}
/* The pattern was namespace-qualified */
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_CmdInfo info;
Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr);
Tcl_Command origin = TclGetOriginalCommand(token);
if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
continue; /* Not an imported command */
}
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
/*
* Original not in namespace we're matching.
* Check the first link in the import chain.
*/
Command *cmdPtr = (Command *) token;
ImportedCmdData *dataPtr =
(ImportedCmdData *) cmdPtr->objClientData;
Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
if (firstToken == origin) {
continue;
}
Tcl_GetCommandInfoFromToken(firstToken, &info);
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
continue;
}
origin = firstToken;
}
if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) {
Tcl_DeleteCommandFromToken(interp, token);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 |
Tcl_Interp *interp; /* Interpreter in which to find the
* namespace containing qualName. */
CONST char *qualName; /* A namespace-qualified name of an
* command, variable, or namespace. */
Namespace *cxtNsPtr; /* The namespace in which to start the
* search for qualName's namespace. If NULL
* start from the current namespace.
| | < | 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 |
Tcl_Interp *interp; /* Interpreter in which to find the
* namespace containing qualName. */
CONST char *qualName; /* A namespace-qualified name of an
* command, variable, or namespace. */
Namespace *cxtNsPtr; /* The namespace in which to start the
* search for qualName's namespace. If NULL
* start from the current namespace.
* Ignored if TCL_GLOBAL_ONLY is set. */
int flags; /* Flags controlling the search: an OR'd
* combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY,
* CREATE_NS_IF_UNKNOWN, and
* FIND_ONLY_NS. */
Namespace **nsPtrPtr; /* Address where procedure stores a pointer
* to containing namespace if qualName is
|
| ︙ | ︙ | |||
1661 1662 1663 1664 1665 1666 1667 |
CONST char *nsName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer;
int len;
/*
* Determine the context namespace nsPtr in which to start the primary
| < | | | | | < < | | 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 |
CONST char *nsName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer;
int len;
/*
* Determine the context namespace nsPtr in which to start the primary
* search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY
* was specified, search from the global namespace. Otherwise, use the
* namespace given in cxtNsPtr, or if that is NULL, use the current
* namespace context. Note that we always treat two or more
* adjacent ":"s as a namespace separator.
*/
if (flags & TCL_GLOBAL_ONLY) {
nsPtr = globalNsPtr;
} else if (nsPtr == NULL) {
if (iPtr->varFramePtr != NULL) {
nsPtr = iPtr->varFramePtr->nsPtr;
} else {
nsPtr = iPtr->globalNsPtr;
}
|
| ︙ | ︙ | |||
2027 2028 2029 2030 2031 2032 2033 |
*/
cmdPtr = NULL;
for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
simpleName);
| | | | | > | 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 |
*/
cmdPtr = NULL;
for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
}
}
}
if (cmdPtr != NULL) {
return (Tcl_Command) cmdPtr;
} else if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown command \"", name, "\"", (char *) NULL);
}
|
| ︙ | ︙ | |||
2866 2867 2868 2869 2870 2871 2872 |
* the command line are valid, and report any errors.
*/
for (i = 2; i < objc; i++) {
name = Tcl_GetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name,
(Tcl_Namespace *) NULL, /*flags*/ 0);
| | | 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 |
* the command line are valid, and report any errors.
*/
for (i = 2; i < objc; i++) {
name = Tcl_GetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name,
(Tcl_Namespace *) NULL, /*flags*/ 0);
if (namespacePtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown namespace \"", Tcl_GetString(objv[i]),
"\" in namespace delete command", (char *) NULL);
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 |
if (result != TCL_OK) {
return TCL_ERROR;
}
frame.objc = objc;
frame.objv = objv; /* ref counts do not need to be incremented here */
if (objc == 4) {
result = Tcl_EvalObjEx(interp, objv[3], 0);
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result. Tcl_EvalObjEx will delete
* the object when it decrements its refcount after eval'ing it.
*/
objPtr = Tcl_ConcatObj(objc-3, objv+3);
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (result == TCL_ERROR) {
char msg[256 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)",
namespacePtr->fullName, interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
| > > > > > > > > > > > | 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 |
if (result != TCL_OK) {
return TCL_ERROR;
}
frame.objc = objc;
frame.objv = objv; /* ref counts do not need to be incremented here */
if (objc == 4) {
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objv[3], 0);
#else
/* TIP #280 : Make invoker available to eval'd script */
Interp* iPtr = (Interp*) interp;
result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3);
#endif
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result. Tcl_EvalObjEx will delete
* the object when it decrements its refcount after eval'ing it.
*/
objPtr = Tcl_ConcatObj(objc-3, objv+3);
#ifndef TCL_TIP280
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
#else
/* TIP #280. Make invoking context available to eval'd script */
result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
#endif
}
if (result == TCL_ERROR) {
char msg[256 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)",
namespacePtr->fullName, interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
|
| ︙ | ︙ |
Changes to generic/tclNotify.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclNotify.c,v 1.11.2.2 2005/04/26 00:46:02 das Exp $ */ #include "tclInt.h" #include "tclPort.h" extern TclStubs tclStubs; |
| ︙ | ︙ | |||
64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
* called during an event source traversal. */
EventSource *firstEventSourcePtr;
/* Pointer to first event source in
* list of event sources for this thread. */
Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */
ClientData clientData; /* Opaque handle for platform specific
* notifier. */
struct ThreadSpecificData *nextPtr;
/* Next notifier in global list of notifiers.
* Access is controlled by the listLock global
* mutex. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
| > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
* called during an event source traversal. */
EventSource *firstEventSourcePtr;
/* Pointer to first event source in
* list of event sources for this thread. */
Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */
ClientData clientData; /* Opaque handle for platform specific
* notifier. */
int initialized; /* 1 if notifier has been initialized. */
struct ThreadSpecificData *nextPtr;
/* Next notifier in global list of notifiers.
* Access is controlled by the listLock global
* mutex. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
|
| ︙ | ︙ | |||
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&listLock);
tsdPtr->threadId = Tcl_GetCurrentThread();
tsdPtr->clientData = tclStubs.tcl_InitNotifier();
tsdPtr->nextPtr = firstNotifierPtr;
firstNotifierPtr = tsdPtr;
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeNotifier --
*
* Finalize the thread local data structures for the notifier
* subsystem.
*
* Results:
* None.
*
* Side effects:
* Removes the notifier associated with the current thread from
| > | > > > > > > > > > > > > | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&listLock);
tsdPtr->threadId = Tcl_GetCurrentThread();
tsdPtr->clientData = tclStubs.tcl_InitNotifier();
tsdPtr->initialized = 1;
tsdPtr->nextPtr = firstNotifierPtr;
firstNotifierPtr = tsdPtr;
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeNotifier --
*
* Finalize the thread local data structures for the notifier
* subsystem.
*
* Results:
* None.
*
* Side effects:
* Removes the notifier associated with the current thread from
* the global notifier list. This is done only if the notifier
* was initialized for this thread by call to TclInitNotifier().
* This is always true for threads which have been seeded with
* an Tcl interpreter, since the call to Tcl_CreateInterp will,
* among other things, call TclInitializeSubsystems() and this
* one will, in turn, call the TclInitNotifier() for the thread.
* For threads created without the Tcl interpreter, though,
* nobody is explicitly nor implicitly calling the TclInitNotifier
* hence, TclFinalizeNotifier should not be performed at all.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeNotifier()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadSpecificData **prevPtrPtr;
Tcl_Event *evPtr, *hold;
if (!tsdPtr->initialized) {
return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
for (evPtr = tsdPtr->firstEventPtr; evPtr != (Tcl_Event *) NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
ckfree((char *) hold);
}
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
if (*prevPtrPtr == tsdPtr) {
*prevPtrPtr = tsdPtr->nextPtr;
break;
}
}
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
| > | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
if (*prevPtrPtr == tsdPtr) {
*prevPtrPtr = tsdPtr->nextPtr;
break;
}
}
tsdPtr->initialized = 0;
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 |
}
/*
* Ask Tcl to service a queued event, if there are any.
*/
if (Tcl_ServiceEvent(flags)) {
| | | 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 |
}
/*
* Ask Tcl to service a queued event, if there are any.
*/
if (Tcl_ServiceEvent(flags)) {
result = 1;
break;
}
/*
* If TCL_DONT_WAIT is set, be sure to poll rather than
* blocking, otherwise reset the block time to infinity.
*/
|
| ︙ | ︙ |
Changes to generic/tclObj.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclObj.c -- * * This file contains Tcl object-related procedures that are used by * many Tcl commands. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * Copyright (c) 2001 by ActiveState Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclObj.c -- * * This file contains Tcl object-related procedures that are used by * many Tcl commands. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * Copyright (c) 2001 by ActiveState Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclObj.c,v 1.42.2.14 2005/11/29 14:02:04 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include "tclPort.h" /* |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 63 64 65 | static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); | > > < > > | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | static int SetBooleanFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *objPtr)); static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); #ifndef TCL_WIDE_INT_IS_LONG static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); #endif /* * Prototypes for the array hash key methods. */ |
| ︙ | ︙ | |||
122 123 124 125 126 127 128 |
"int", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
| < > > > > < > > > > > > > | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
"int", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
Tcl_ObjType tclWideIntType = {
"wideInt", /* name */
(Tcl_FreeInternalRepProc *) NULL, /* freeIntRepProc */
(Tcl_DupInternalRepProc *) NULL, /* dupIntRepProc */
#ifdef TCL_WIDE_INT_IS_LONG
UpdateStringOfInt, /* updateStringProc */
#else /* !TCL_WIDE_INT_IS_LONG */
UpdateStringOfWideInt, /* updateStringProc */
#endif
SetWideIntFromAny /* setFromAnyProc */
};
/*
* The structure below defines the Tcl obj hash key type.
*/
Tcl_HashKeyType tclObjHashKeyType = {
TCL_HASH_KEY_TYPE_VERSION, /* version */
0, /* flags */
HashObjKey, /* hashKeyProc */
CompareObjKeys, /* compareKeysProc */
AllocObjEntry, /* allocEntryProc */
FreeObjEntry /* freeEntryProc */
};
/*
* The structure below defines the command name Tcl object type by means of
* procedures that can be invoked by generic object code. Objects of this
* type cache the Command pointer that results from looking up command names
* in the command hashtable. Such objects appear as the zeroth ("command
* name") argument in a Tcl command.
*
* NOTE: the ResolvedCmdName that gets cached is stored in the
* twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused.
* You might think you could use the simpler otherValuePtr field to
* store the single ResolvedCmdName pointer, but DO NOT DO THIS. It
* seems that some extensions use the second internal pointer field
* of the twoPtrValue field for their own purposes.
*/
static Tcl_ObjType tclCmdNameType = {
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
(Tcl_UpdateStringProc *) NULL, /* updateStringProc */
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
Tcl_MutexUnlock(&tableMutex);
Tcl_RegisterObjType(&tclBooleanType);
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclEndOffsetType);
Tcl_RegisterObjType(&tclIntType);
| < < | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
Tcl_MutexUnlock(&tableMutex);
Tcl_RegisterObjType(&tclBooleanType);
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
Tcl_RegisterObjType(&tclEndOffsetType);
Tcl_RegisterObjType(&tclIntType);
Tcl_RegisterObjType(&tclWideIntType);
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclProcBodyType);
Tcl_RegisterObjType(&tclArraySearchType);
Tcl_RegisterObjType(&tclIndexType);
Tcl_RegisterObjType(&tclNsNameType);
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 |
Tcl_MutexUnlock(&tclObjMutex);
#endif
}
/*
*----------------------------------------------------------------------
*
| | | < | | | > > > > > > < < < | 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
Tcl_MutexUnlock(&tclObjMutex);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeObjects --
*
* This procedure is called by Tcl_Finalize to clean up all
* registered Tcl_ObjType's and to reset the tclFreeObjList.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeObjects()
{
Tcl_MutexLock(&tableMutex);
if (typeTableInitialized) {
Tcl_DeleteHashTable(&typeTable);
typeTableInitialized = 0;
}
Tcl_MutexUnlock(&tableMutex);
/*
* All we do here is reset the head pointer of the linked list of
* free Tcl_Obj's to NULL; the memory finalization will take care
* of releasing memory for us.
*/
Tcl_MutexLock(&tclObjMutex);
tclFreeObjList = NULL;
Tcl_MutexUnlock(&tclObjMutex);
}
/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
*
|
| ︙ | ︙ | |||
315 316 317 318 319 320 321 |
void
Tcl_RegisterObjType(typePtr)
Tcl_ObjType *typePtr; /* Information about object type;
* storage must be statically
* allocated (must live forever). */
{
| < < < < < < < < < | < < < < | < < < | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
void
Tcl_RegisterObjType(typePtr)
Tcl_ObjType *typePtr; /* Information about object type;
* storage must be statically
* allocated (must live forever). */
{
int new;
Tcl_MutexLock(&tableMutex);
Tcl_SetHashValue(
Tcl_CreateHashEntry(&typeTable, typePtr->name, &new), typePtr);
Tcl_MutexUnlock(&tableMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendAllObjTypes --
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
Tcl_Interp *interp; /* Interpreter used for error reporting. */
Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
* name of each registered type is appended
* as a list element. */
{
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
| > | | > > > | > > > > > | < | | < < < < | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 |
Tcl_Interp *interp; /* Interpreter used for error reporting. */
Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
* name of each registered type is appended
* as a list element. */
{
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int objc;
Tcl_Obj **objv;
/*
* Get the test for a valid list out of the way first.
*/
if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
return TCL_ERROR;
}
/*
* Type names are NUL-terminated, not counted strings.
* This code relies on that.
*/
Tcl_MutexLock(&tableMutex);
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj(Tcl_GetHashKey(&typeTable, hPtr), -1));
}
Tcl_MutexUnlock(&tableMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
417 418 419 420 421 422 423 |
*/
Tcl_ObjType *
Tcl_GetObjType(typeName)
CONST char *typeName; /* Name of Tcl object type to look up. */
{
register Tcl_HashEntry *hPtr;
| | < < | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 |
*/
Tcl_ObjType *
Tcl_GetObjType(typeName)
CONST char *typeName; /* Name of Tcl object type to look up. */
{
register Tcl_HashEntry *hPtr;
Tcl_ObjType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != (Tcl_HashEntry *) NULL) {
typePtr = (Tcl_ObjType *) Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConvertToType --
*
|
| ︙ | ︙ | |||
615 616 617 618 619 620 621 |
register Tcl_Obj *prevPtr, *objPtr;
register int i;
/*
* This has been noted by Purify to be a potential leak. The problem is
* that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
* Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of
| | > > > | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
register Tcl_Obj *prevPtr, *objPtr;
register int i;
/*
* This has been noted by Purify to be a potential leak. The problem is
* that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
* Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of
* actually freeing the memory. TclFinalizeObjects() does not ckfree()
* this memory, but leaves it to Tcl's memory subsystem finalziation to
* release it. Purify apparently can't figure that out, and fires a
* false alarm.
*/
basePtr = (char *) ckalloc(bytesToAlloc);
memset(basePtr, 0, bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
|
| ︙ | ︙ | |||
873 874 875 876 877 878 879 | /* *---------------------------------------------------------------------- * * Tcl_NewBooleanObj -- * * This procedure is normally called when not debugging: i.e., when | | | 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 | /* *---------------------------------------------------------------------- * * Tcl_NewBooleanObj -- * * This procedure is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and * initializes it from the argument boolean value. A nonzero * "boolValue" is coerced to 1. * * When TCL_MEM_DEBUG is defined, this procedure just returns the * result of calling the debugging version Tcl_DbNewBooleanObj. * * Results: |
| ︙ | ︙ | |||
1103 1104 1105 1106 1107 1108 1109 |
* of numerical type, parse its string rep.
*/
if (objPtr->typePtr == &tclIntType) {
newBool = (objPtr->internalRep.longValue != 0);
} else if (objPtr->typePtr == &tclDoubleType) {
newBool = (objPtr->internalRep.doubleValue != 0.0);
| < | < | 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 |
* of numerical type, parse its string rep.
*/
if (objPtr->typePtr == &tclIntType) {
newBool = (objPtr->internalRep.longValue != 0);
} else if (objPtr->typePtr == &tclDoubleType) {
newBool = (objPtr->internalRep.doubleValue != 0.0);
} else if (objPtr->typePtr == &tclWideIntType) {
newBool = (objPtr->internalRep.wideValue != 0);
} else {
/*
* Copy the string converting its characters to lower case.
*/
for (i = 0; (i < 9) && (i < length); i++) {
c = string[i];
|
| ︙ | ︙ | |||
1733 1734 1735 1736 1737 1738 1739 |
int
Tcl_GetIntFromObj(interp, objPtr, intPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get a int. */
register int *intPtr; /* Place to store resulting int. */
{
| < > | > > > > > | | > > > > > > > | > | > | < > > > | < | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > < | < < < < < > | > > > > | 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 |
int
Tcl_GetIntFromObj(interp, objPtr, intPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get a int. */
register int *intPtr; /* Place to store resulting int. */
{
int result;
Tcl_WideInt w = 0;
/*
* If the object isn't already an integer of any width, try to
* convert it to one.
*/
if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
result = SetIntOrWideFromAny(interp, objPtr);
if (result != TCL_OK) {
return result;
}
}
/*
* Object should now be either int or wide. Get its value.
*/
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
w = objPtr->internalRep.wideValue;
} else
#endif
{
w = Tcl_LongAsWide(objPtr->internalRep.longValue);
}
if ((LLONG_MAX > UINT_MAX)
&& ((w > UINT_MAX) || (w < -(Tcl_WideInt)UINT_MAX))) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent as non-long integer",
-1));
}
return TCL_ERROR;
}
*intPtr = (int)w;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetIntFromAny --
*
* Attempts to force the internal representation for a Tcl object
* to tclIntType, specifically.
*
* Results:
* The return value is a standard object Tcl result. If an
* error occurs during conversion, an error message is left in
* the interpreter's result unless "interp" is NULL.
*
*----------------------------------------------------------------------
*/
static int
SetIntFromAny( Tcl_Interp* interp,
/* Tcl interpreter */
Tcl_Obj* objPtr )
/* Pointer to the object to convert */
{
int result;
result = SetIntOrWideFromAny( interp, objPtr );
if ( result != TCL_OK ) {
return result;
}
if ( objPtr->typePtr != &tclIntType ) {
if ( interp != NULL ) {
char *s = "integer value too large to represent";
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetIntOrWideFromAny --
*
* Attempt to generate an integer internal form for the Tcl object
* "objPtr".
*
* Results:
* The return value is a standard object Tcl result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If no error occurs, an int is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
static int
SetIntOrWideFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
char *string, *end;
int length;
register char *p;
unsigned long newLong;
int isNegative = 0;
int isWide = 0;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
p = string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Now parse "objPtr"s string as an int. We use an implementation here
* that doesn't report errors in interp if interp is NULL. Note: use
* strtoul instead of strtol for integer conversions to allow full-size
* unsigned numbers, but don't depend on strtoul to handle sign
* characters; it won't in some implementations.
*/
errno = 0;
for ( ; isspace(UCHAR(*p)); p++) { /* INTL: ISO space. */
/* Empty loop body. */
}
if (*p == '-') {
p++;
isNegative = 1;
} else if (*p == '+') {
p++;
}
if (!isdigit(UCHAR(*p))) {
badInteger:
if (interp != NULL) {
/*
* Must copy string before resetting the result in case a caller
* is trying to convert the interpreter's result to an int.
*/
char buf[100];
sprintf(buf, "expected integer but got \"%.50s\"", string);
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
TclCheckBadOctal(interp, string);
}
return TCL_ERROR;
}
newLong = strtoul(p, &end, 0);
if (end == p) {
goto badInteger;
}
if (errno == ERANGE) {
if (interp != NULL) {
char *s = "integer value too large to represent";
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, (char *) NULL);
|
| ︙ | ︙ | |||
1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 |
&& isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (end != (string+length)) {
goto badInteger;
}
/*
* The conversion to int succeeded. Free the old internalRep before
* setting the new one. We do this as late as possible to allow the
* conversion code, in particular Tcl_GetStringFromObj, to use that old
* internalRep.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
| > > > > > > > > > > > > > > > > > | > | > | 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 |
&& isspace(UCHAR(*end))) { /* INTL: ISO space. */
end++;
}
if (end != (string+length)) {
goto badInteger;
}
/*
* If the resulting integer will exceed the range of a long,
* put it into a wide instead. (Tcl Bug #868489)
*/
#ifndef TCL_WIDE_INT_IS_LONG
if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1)
|| (!isNegative && newLong > LONG_MAX)) {
isWide = 1;
}
#endif
/*
* The conversion to int succeeded. Free the old internalRep before
* setting the new one. We do this as late as possible to allow the
* conversion code, in particular Tcl_GetStringFromObj, to use that old
* internalRep.
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
if (isWide) {
objPtr->internalRep.wideValue =
(isNegative ? -(Tcl_WideInt)newLong : (Tcl_WideInt)newLong);
objPtr->typePtr = &tclWideIntType;
} else {
objPtr->internalRep.longValue =
(isNegative ? -(long)newLong : (long)newLong);
objPtr->typePtr = &tclIntType;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfInt --
|
| ︙ | ︙ | |||
2098 2099 2100 2101 2102 2103 2104 |
Tcl_GetLongFromObj(interp, objPtr, longPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get a long. */
register long *longPtr; /* Place to store resulting long. */
{
register int result;
| > > > > > > > > | > > > > > > > > > | > > | > > > > > | > > > > | < | < | | 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 |
Tcl_GetLongFromObj(interp, objPtr, longPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get a long. */
register long *longPtr; /* Place to store resulting long. */
{
register int result;
if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) {
result = SetIntOrWideFromAny(interp, objPtr);
if (result != TCL_OK) {
return result;
}
}
#ifndef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclWideIntType) {
/*
* If the object is already a wide integer, don't convert it.
* This code allows for any integer in the range -ULONG_MAX to
* ULONG_MAX to be converted to a long, ignoring overflow.
* The rule preserves existing semantics for conversion of
* integers on input, but avoids inadvertent demotion of
* wide integers to 32-bit ones in the internal rep.
*/
Tcl_WideInt w = objPtr->internalRep.wideValue;
if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) {
*longPtr = Tcl_WideAsLong(w);
return TCL_OK;
} else {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
}
return TCL_ERROR;
}
}
#endif
*longPtr = objPtr->internalRep.longValue;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* SetWideIntFromAny --
*
|
| ︙ | ︙ | |||
2129 2130 2131 2132 2133 2134 2135 | * Side effects: * If no error occurs, an int is stored as "objPtr"s internal * representation. * *---------------------------------------------------------------------- */ | < > | 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 |
* Side effects:
* If no error occurs, an int is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
static int
SetWideIntFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
char *string, *end;
int length;
register char *p;
Tcl_WideInt newWide;
/*
|
| ︙ | ︙ | |||
2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 |
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.wideValue = newWide;
objPtr->typePtr = &tclWideIntType;
return TCL_OK;
}
| > > > > > < | 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 |
*/
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.wideValue = newWide;
#else
if (TCL_ERROR == SetIntFromAny(interp, objPtr)) {
return TCL_ERROR;
}
#endif
objPtr->typePtr = &tclWideIntType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfWideInt --
*
* Update the string representation for a wide integer object.
|
| ︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewWideIntObj(wideValue)
register Tcl_WideInt wideValue; /* Wide integer used to initialize
* the new object. */
{
| < < < < | 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewWideIntObj(wideValue)
register Tcl_WideInt wideValue; /* Wide integer used to initialize
* the new object. */
{
register Tcl_Obj *objPtr;
TclNewObj(objPtr);
objPtr->bytes = NULL;
objPtr->internalRep.wideValue = wideValue;
objPtr->typePtr = &tclWideIntType;
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewWideIntObj --
|
| ︙ | ︙ | |||
2371 2372 2373 2374 2375 2376 2377 |
* the new object. */
CONST char *file; /* The name of the source file
* calling this procedure; used for
* debugging. */
int line; /* Line number in the source file;
* used for debugging. */
{
| < < < < | 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 |
* the new object. */
CONST char *file; /* The name of the source file
* calling this procedure; used for
* debugging. */
int line; /* Line number in the source file;
* used for debugging. */
{
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
objPtr->internalRep.wideValue = wideValue;
objPtr->typePtr = &tclWideIntType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewWideIntObj(wideValue, file, line)
register Tcl_WideInt wideValue; /* Long integer used to initialize
|
| ︙ | ︙ | |||
2425 2426 2427 2428 2429 2430 2431 |
void
Tcl_SetWideIntObj(objPtr, wideValue)
register Tcl_Obj *objPtr; /* Object w. internal rep to init. */
register Tcl_WideInt wideValue; /* Wide integer used to initialize
* the object's value. */
{
| < < < < | 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 |
void
Tcl_SetWideIntObj(objPtr, wideValue)
register Tcl_Obj *objPtr; /* Object w. internal rep to init. */
register Tcl_WideInt wideValue; /* Wide integer used to initialize
* the object's value. */
{
register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
if (Tcl_IsShared(objPtr)) {
panic("Tcl_SetWideIntObj called with shared object");
}
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.wideValue = wideValue;
objPtr->typePtr = &tclWideIntType;
Tcl_InvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetWideIntFromObj --
*
|
| ︙ | ︙ | |||
2471 2472 2473 2474 2475 2476 2477 |
int
Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* Object from which to get a wide int. */
register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */
{
| < < < < < < > > > > > > > > > > > < | 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 |
int
Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* Object from which to get a wide int. */
register Tcl_WideInt *wideIntPtr; /* Place to store resulting long. */
{
register int result;
if (objPtr->typePtr == &tclWideIntType) {
gotWide:
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
/*
* This cast is safe; all valid ints/longs are wides.
*/
objPtr->internalRep.wideValue =
Tcl_LongAsWide(objPtr->internalRep.longValue);
objPtr->typePtr = &tclWideIntType;
goto gotWide;
}
result = SetWideIntFromAny(interp, objPtr);
if (result == TCL_OK) {
*wideIntPtr = objPtr->internalRep.wideValue;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbIncrRefCount --
*
|
| ︙ | ︙ | |||
2719 2720 2721 2722 2723 2724 2725 |
return 1;
}
/*
* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
* in a register.
*/
| | | | 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 |
return 1;
}
/*
* Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being
* in a register.
*/
p1 = TclGetString(objPtr1);
l1 = objPtr1->length;
p2 = TclGetString(objPtr2);
l2 = objPtr2->length;
/*
* Only compare if the string representations are of the same length.
*/
if (l1 == l2) {
for (;; p1++, p2++, l1--) {
|
| ︙ | ︙ | |||
2791 2792 2793 2794 2795 2796 2797 |
static unsigned int
HashObjKey(tablePtr, keyPtr)
Tcl_HashTable *tablePtr; /* Hash table. */
VOID *keyPtr; /* Key from which to compute hash value. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
| | | | | < < < < < < | < < < | | 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 |
static unsigned int
HashObjKey(tablePtr, keyPtr)
Tcl_HashTable *tablePtr; /* Hash table. */
VOID *keyPtr; /* Key from which to compute hash value. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
CONST char *string = TclGetString(objPtr);
int length = objPtr->length;
unsigned int result;
int i;
/*
* I tried a zillion different hash functions and asked many other
* people for advice. Many people had their own favorite functions,
* all different, but no-one had much idea why they were good ones.
* I chose the one below (multiply by 9 and add new character)
* because of the following reasons:
*
* 1. Multiplying by 10 is perfect for keys that are decimal strings,
* and multiplying by 9 is just about as good.
* 2. Times-9 is (shift-left-3) plus (old). This means that each
* character's bits hang around in the low-order bits of the
* hash value for ever, plus they spread fairly rapidly up to
* the high-order bits to fill out the hash value. This seems
* works well both for decimal and non-decimal strings.
*/
result = 0;
for (i=0 ; i<length ; i++) {
result += (result<<3) + string[i];
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2892 2893 2894 2895 2896 2897 2898 |
if (objPtr->typePtr != &tclCmdNameType) {
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
iPtr->varFramePtr = savedFramePtr;
return (Tcl_Command) NULL;
}
}
| | | 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 |
if (objPtr->typePtr != &tclCmdNameType) {
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
iPtr->varFramePtr = savedFramePtr;
return (Tcl_Command) NULL;
}
}
resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
/*
* Get the current namespace.
*/
if (iPtr->varFramePtr != NULL) {
currNsPtr = iPtr->varFramePtr->nsPtr;
|
| ︙ | ︙ | |||
2931 2932 2933 2934 2935 2936 2937 |
if (cmdPtr == NULL) {
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
iPtr->varFramePtr = savedFramePtr;
return (Tcl_Command) NULL;
}
| | | 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 |
if (cmdPtr == NULL) {
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
iPtr->varFramePtr = savedFramePtr;
return (Tcl_Command) NULL;
}
resPtr = (ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL) {
cmdPtr = resPtr->cmdPtr;
}
}
iPtr->varFramePtr = savedFramePtr;
return (Tcl_Command) cmdPtr;
}
|
| ︙ | ︙ | |||
3032 3033 3034 3035 3036 3037 3038 |
static void
FreeCmdNameInternalRep(objPtr)
register Tcl_Obj *objPtr; /* CmdName object with internal
* representation to free. */
{
register ResolvedCmdName *resPtr =
| | | 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 |
static void
FreeCmdNameInternalRep(objPtr)
register Tcl_Obj *objPtr; /* CmdName object with internal
* representation to free. */
{
register ResolvedCmdName *resPtr =
(ResolvedCmdName *) objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL) {
/*
* Decrement the reference count of the ResolvedCmdName structure.
* If there are no more uses, free the ResolvedCmdName structure.
*/
|
| ︙ | ︙ | |||
3081 3082 3083 3084 3085 3086 3087 |
static void
DupCmdNameInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
register ResolvedCmdName *resPtr =
| | | 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 |
static void
DupCmdNameInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
register ResolvedCmdName *resPtr =
(ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
resPtr->refCount++;
}
copyPtr->typePtr = &tclCmdNameType;
|
| ︙ | ︙ |
Changes to generic/tclPanic.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * Copyright (c) 1988-1993 The Regents of the University of California. * Copyright (c) 1994 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPanic.c,v 1.4.12.2 2006/03/09 23:11:23 dgp Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The panicProc variable contains a pointer to an application |
| ︙ | ︙ |
Changes to generic/tclParse.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclParse.c,v 1.25.2.1 2006/09/24 21:15:10 msofer Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The following table provides parsing information about each possible |
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
int wordIndex; /* Index of word token for current word. */
int terminators; /* CHAR_TYPE bits that indicate the end
* of a command. */
CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
int scanned;
| | | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 |
int wordIndex; /* Index of word token for current word. */
int terminators; /* CHAR_TYPE bits that indicate the end
* of a command. */
CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
int scanned;
if ((string == NULL) && (numBytes!=0)) {
if (interp != NULL) {
Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
}
return TCL_ERROR;
}
if (numBytes < 0) {
numBytes = strlen(string);
|
| ︙ | ︙ |
Changes to generic/tclParseExpr.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclParseExpr.c,v 1.17.2.2 2005/05/20 17:19:10 vasiljevic Exp $ */ #include "tclInt.h" /* * The stuff below is a bit of a hack so that this file can be used in * environments that include no UNIX, i.e. no errno: just arrange to use |
| ︙ | ︙ | |||
1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 |
firstIndex = parsePtr->numTokens;
switch (lexeme) {
case LITERAL:
/*
* Int or double number.
*/
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = infoPtr->start;
tokenPtr->size = infoPtr->size;
| > | 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 |
firstIndex = parsePtr->numTokens;
switch (lexeme) {
case LITERAL:
/*
* Int or double number.
*/
tokenizeLiteral:
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = infoPtr->start;
tokenPtr->size = infoPtr->size;
|
| ︙ | ︙ | |||
1364 1365 1366 1367 1368 1369 1370 | tokenPtr->type = TCL_TOKEN_WORD; tokenPtr->start = exprTokenPtr->start; tokenPtr->size = exprTokenPtr->size; tokenPtr->numComponents = exprTokenPtr->numComponents-1; } break; | > > | | < < < < < < | < < > > > > > > > > > > > > > > > < < < | | > > > > > > > > > > > | 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 |
tokenPtr->type = TCL_TOKEN_WORD;
tokenPtr->start = exprTokenPtr->start;
tokenPtr->size = exprTokenPtr->size;
tokenPtr->numComponents = exprTokenPtr->numComponents-1;
}
break;
case STREQ:
case STRNEQ:
case FUNC_NAME: {
/*
* math_func '(' expr {',' expr} ')'
*/
ParseInfo savedInfo = *infoPtr;
code = GetLexeme(infoPtr); /* skip over function name */
if (code != TCL_OK) {
return code;
}
if (infoPtr->lexeme != OPEN_PAREN) {
int code;
Tcl_DString functionName;
Tcl_HashEntry *hPtr;
Interp *iPtr = (Interp *) infoPtr->parsePtr->interp;
Tcl_Obj *objPtr = Tcl_NewStringObj(savedInfo.start, savedInfo.size);
/* Check for boolean literals (true, false, yes, no, on, off) */
Tcl_IncrRefCount(objPtr);
code = Tcl_ConvertToType(NULL, objPtr, &tclBooleanType);
Tcl_DecrRefCount(objPtr);
if (code == TCL_OK) {
*infoPtr = savedInfo;
goto tokenizeLiteral;
}
/*
* Guess what kind of error we have by trying to tell
* whether we have a function or variable name here.
* Alas, this makes the parser more tightly bound with the
* rest of the interpreter, but that is the only way to
* give a sensible message here. Still, it is not too
* serious as this is only done when generating an error.
*/
/*
* Look up the name as a function name. We need a writable
* copy (DString) so we can terminate it with a NULL for
* the benefit of Tcl_FindHashEntry which operates on
* NULL-terminated string keys.
*/
Tcl_DStringInit(&functionName);
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
Tcl_DStringAppend(&functionName,
savedInfo.start, savedInfo.size));
Tcl_DStringFree(&functionName);
/*
* Assume that we have an attempted variable reference
* unless we've got a function name, as the set of
* potential function names is typically much smaller.
*/
if (hPtr != NULL) {
LogSyntaxError(infoPtr,
"expected parenthesis enclosing function arguments");
} else {
LogSyntaxError(infoPtr,
"variable references require preceding $");
}
return TCL_ERROR;
}
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_OPERATOR;
tokenPtr->start = savedInfo.start;
tokenPtr->size = savedInfo.size;
tokenPtr->numComponents = 0;
parsePtr->numTokens++;
code = GetLexeme(infoPtr); /* skip over '(' */
if (code != TCL_OK) {
return code;
}
while (infoPtr->lexeme != CLOSE_PAREN) {
code = ParseCondExpr(infoPtr);
|
| ︙ | ︙ | |||
1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 |
}
}
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start);
exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
break;
case COMMA:
LogSyntaxError(infoPtr,
"commas can only separate function arguments");
return TCL_ERROR;
case END:
LogSyntaxError(infoPtr, "premature end of expression");
| > | 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 |
}
}
exprTokenPtr = &parsePtr->tokenPtr[exprIndex];
exprTokenPtr->size = (infoPtr->next - exprTokenPtr->start);
exprTokenPtr->numComponents = parsePtr->numTokens - firstIndex;
break;
}
case COMMA:
LogSyntaxError(infoPtr,
"commas can only separate function arguments");
return TCL_ERROR;
case END:
LogSyntaxError(infoPtr, "premature end of expression");
|
| ︙ | ︙ | |||
1840 1841 1842 1843 1844 1845 1846 | offset = Tcl_UtfToUniChar(utfBytes, &ch); } c = UCHAR(ch); } infoPtr->size = (src - infoPtr->start); infoPtr->next = src; parsePtr->term = infoPtr->next; | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 |
offset = Tcl_UtfToUniChar(utfBytes, &ch);
}
c = UCHAR(ch);
}
infoPtr->size = (src - infoPtr->start);
infoPtr->next = src;
parsePtr->term = infoPtr->next;
return TCL_OK;
}
infoPtr->lexeme = UNKNOWN_CHAR;
return TCL_OK;
}
}
|
| ︙ | ︙ |
Changes to generic/tclPipe.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclPipe.c -- * * This file contains the generic portion of the command channel * driver as well as various utility routines used in managing * subprocesses. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclPipe.c -- * * This file contains the generic portion of the command channel * driver as well as various utility routines used in managing * subprocesses. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPipe.c,v 1.7.2.5 2006/03/16 00:35:58 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * A linked list of the following structures is used to keep track |
| ︙ | ︙ | |||
64 65 66 67 68 69 70 |
*----------------------------------------------------------------------
*/
static TclFile
FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr,
releasePtr)
Tcl_Interp *interp; /* Intepreter to use for error reporting. */
| | < < > > | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
*----------------------------------------------------------------------
*/
static TclFile
FileForRedirect(interp, spec, atOK, arg, nextArg, flags, skipPtr, closePtr,
releasePtr)
Tcl_Interp *interp; /* Intepreter to use for error reporting. */
CONST char *spec; /* Points to character just after
* redirection character. */
int atOK; /* Non-zero means that '@' notation can be
* used to specify a channel, zero means that
* it isn't. */
CONST char *arg; /* Pointer to entire argument containing
* spec: used for error reporting. */
CONST char *nextArg; /* Next argument in argc/argv array, if needed
* for file name or channel name. May be
* NULL. */
int flags; /* Flags to use for opening file or to
* specify mode for channel. */
int *skipPtr; /* Filled with 1 if redirection target was
* in spec, 2 if it was in nextArg. */
|
| ︙ | ︙ | |||
103 104 105 106 107 108 109 |
}
chan = Tcl_GetChannel(interp, spec, NULL);
if (chan == (Tcl_Channel) NULL) {
return NULL;
}
file = TclpMakeFile(chan, writing ? TCL_WRITABLE : TCL_READABLE);
if (file == NULL) {
| | | | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
}
chan = Tcl_GetChannel(interp, spec, NULL);
if (chan == (Tcl_Channel) NULL) {
return NULL;
}
file = TclpMakeFile(chan, writing ? TCL_WRITABLE : TCL_READABLE);
if (file == NULL) {
Tcl_AppendResult(interp, "channel \"", Tcl_GetChannelName(chan),
"\" wasn't opened for ",
((writing) ? "writing" : "reading"), (char *) NULL);
return NULL;
}
*releasePtr = 1;
if (writing) {
/*
* Be sure to flush output to the file, so that anything
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
spec = nextArg;
if (spec == NULL) {
goto badLastArg;
}
*skipPtr = 2;
}
name = Tcl_TranslateFileName(interp, spec, &nameString);
| | < < | > | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
spec = nextArg;
if (spec == NULL) {
goto badLastArg;
}
*skipPtr = 2;
}
name = Tcl_TranslateFileName(interp, spec, &nameString);
if (name == NULL) {
return NULL;
}
file = TclpOpenFile(name, flags);
Tcl_DStringFree(&nameString);
if (file == NULL) {
Tcl_AppendResult(interp, "couldn't ",
((writing) ? "write" : "read"), " file \"", spec, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return NULL;
}
|
| ︙ | ︙ | |||
504 505 506 507 508 509 510 |
TclFile errorFile = NULL; /* Writable file for error output from all
* commands in pipeline. NULL means use
* stderr. */
int errorClose = 0; /* If non-zero, then errorFile should be
* closed when cleaning up. */
int errorRelease = 0;
CONST char *p;
| > | | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
TclFile errorFile = NULL; /* Writable file for error output from all
* commands in pipeline. NULL means use
* stderr. */
int errorClose = 0; /* If non-zero, then errorFile should be
* closed when cleaning up. */
int errorRelease = 0;
CONST char *p;
CONST char *nextArg;
int skip, lastBar, lastArg, i, j, atOK, flags, needCmd, errorToOutput = 0;
Tcl_DString execBuffer;
TclFile pipeIn;
TclFile curInFile, curOutFile, curErrFile;
Tcl_Channel channel;
if (inPipePtr != NULL) {
*inPipePtr = NULL;
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 549 |
* because the redirection symbols may appear anywhere in the
* command line -- e.g., the '<' that specifies the input to the
* entire pipe may appear at the very end of the argument list.
*/
lastBar = -1;
cmdCount = 1;
for (i = 0; i < argc; i++) {
| > > | > | > | < > > > > > > | | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 |
* because the redirection symbols may appear anywhere in the
* command line -- e.g., the '<' that specifies the input to the
* entire pipe may appear at the very end of the argument list.
*/
lastBar = -1;
cmdCount = 1;
needCmd = 1;
for (i = 0; i < argc; i++) {
errorToOutput = 0;
skip = 0;
p = argv[i];
switch (*p++) {
case '|':
if (*p == '&') {
p++;
}
if (*p == '\0') {
if ((i == (lastBar + 1)) || (i == (argc - 1))) {
Tcl_SetResult(interp,
"illegal use of | or |& in command",
TCL_STATIC);
goto error;
}
}
lastBar = i;
cmdCount++;
needCmd = 1;
break;
case '<':
if (inputClose != 0) {
inputClose = 0;
TclpCloseFile(inputFile);
}
if (inputRelease != 0) {
inputRelease = 0;
TclpReleaseFile(inputFile);
}
if (*p == '<') {
inputFile = NULL;
inputLiteral = p + 1;
skip = 1;
if (*inputLiteral == '\0') {
inputLiteral = ((i + 1) == argc) ? NULL : argv[i + 1];
if (inputLiteral == NULL) {
Tcl_AppendResult(interp, "can't specify \"", argv[i],
"\" as last word in command", (char *) NULL);
goto error;
}
skip = 2;
}
} else {
nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
inputLiteral = NULL;
inputFile = FileForRedirect(interp, p, 1, argv[i],
nextArg, O_RDONLY, &skip, &inputClose, &inputRelease);
if (inputFile == NULL) {
goto error;
}
}
break;
case '>':
atOK = 1;
flags = O_WRONLY | O_CREAT | O_TRUNC;
if (*p == '>') {
p++;
atOK = 0;
/*
* Note that the O_APPEND flag only has an effect on POSIX
* platforms. On Windows, we just have to carry on regardless.
*/
flags = O_WRONLY | O_CREAT | O_APPEND;
}
if (*p == '&') {
if (errorClose != 0) {
errorClose = 0;
TclpCloseFile(errorFile);
}
errorToOutput = 1;
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 640 |
outputRelease = 0;
if (errorFile == outputFile) {
errorRelease = 1;
} else {
TclpReleaseFile(outputFile);
}
}
outputFile = FileForRedirect(interp, p, atOK, argv[i],
| > | | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
outputRelease = 0;
if (errorFile == outputFile) {
errorRelease = 1;
} else {
TclpReleaseFile(outputFile);
}
}
nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
outputFile = FileForRedirect(interp, p, atOK, argv[i],
nextArg, flags, &skip, &outputClose, &outputRelease);
if (outputFile == NULL) {
goto error;
}
if (errorToOutput) {
if (errorClose != 0) {
errorClose = 0;
TclpCloseFile(errorFile);
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
errorClose = 0;
TclpCloseFile(errorFile);
}
if (errorRelease != 0) {
errorRelease = 0;
TclpReleaseFile(errorFile);
}
| > > > > > > > > > > > > > > > > | | | | | > > > > > > > > > > > > > > > | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
errorClose = 0;
TclpCloseFile(errorFile);
}
if (errorRelease != 0) {
errorRelease = 0;
TclpReleaseFile(errorFile);
}
if (atOK && p[0] == '@' && p[1] == '1' && p[2] == '\0') {
/*
* Special case handling of 2>@1 to redirect stderr to the
* exec/open output pipe as well. This is meant for the end
* of the command string, otherwise use |& between commands.
*/
if (i != argc - 1) {
Tcl_AppendResult(interp, "must specify \"", argv[i],
"\" as last word in command", (char *) NULL);
goto error;
}
errorFile = outputFile;
errorToOutput = 2;
skip = 1;
} else {
nextArg = ((i + 1) == argc) ? NULL : argv[i + 1];
errorFile = FileForRedirect(interp, p, atOK, argv[i],
nextArg, flags, &skip, &errorClose, &errorRelease);
if (errorFile == NULL) {
goto error;
}
}
break;
default:
/* Got a command word, not a redirection */
needCmd = 0;
break;
}
if (skip != 0) {
for (j = i + skip; j < argc; j++) {
argv[j - skip] = argv[j];
}
argc -= skip;
i -= 1;
}
}
if (needCmd) {
/* We had a bar followed only by redirections. */
Tcl_SetResult(interp,
"illegal use of | or |& in command",
TCL_STATIC);
goto error;
}
if (inputFile == NULL) {
if (inputLiteral != NULL) {
/*
* The input for the first process is immediate data coming from
* Tcl. Create a temporary file for it and put the data into the
* file.
|
| ︙ | ︙ | |||
761 762 763 764 765 766 767 |
outputRelease = 1;
}
}
}
}
if (errorFile == NULL) {
| > > > > > | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 |
outputRelease = 1;
}
}
}
}
if (errorFile == NULL) {
if (errorToOutput == 2) {
/*
* Handle 2>@1 special case at end of cmd line
*/
errorFile = outputFile;
} else if (errFilePtr != NULL) {
/*
* Set up the standard error output sink for the pipeline, if
* requested. Use a temporary file which is opened, then deleted.
* Could potentially just use pipe, but if it filled up it could
* cause the pipeline to deadlock: we'd be waiting for processes
* to complete before reading stderr, and processes couldn't
* complete because stderr was backed up.
|
| ︙ | ︙ | |||
833 834 835 836 837 838 839 |
}
if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) {
joinThisError = 1;
break;
}
}
}
| < | > | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 |
}
if ((argv[lastArg][1] == '&') && (argv[lastArg][2] == '\0')) {
joinThisError = 1;
break;
}
}
}
/*
* If this is the last segment, use the specified outputFile.
* Otherwise create an intermediate pipe. pipeIn will become the
* curInFile for the next segment of the pipe.
*/
if (lastArg == argc) {
curOutFile = outputFile;
} else {
argv[lastArg] = NULL;
if (TclpCreatePipe(&pipeIn, &curOutFile) == 0) {
Tcl_AppendResult(interp, "couldn't create pipe: ",
Tcl_PosixError(interp), (char *) NULL);
goto error;
}
}
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclPkg.c -- * * This file implements package and version control for Tcl via * the "package" command and a few C APIs. * * Copyright (c) 1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | > | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | /* * tclPkg.c -- * * This file implements package and version control for Tcl via * the "package" command and a few C APIs. * * Copyright (c) 1996 Sun Microsystems, Inc. * Copyright (c) 2006 Andreas Kupries <andreas_kupries@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPkg.c,v 1.9.2.9 2007/03/19 17:06:26 dgp Exp $ * * TIP #268. * Heavily rewritten to handle the extend version numbers, and extended * package requirements. */ #include "tclInt.h" /* * Each invocation of the "package ifneeded" command creates a structure * of the following type, which is used to load the package into the |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
ClientData clientData; /* Client data. */
} Package;
/*
* Prototypes for procedures defined in this file:
*/
static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *string));
static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1,
CONST char *v2,
int *satPtr));
static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name));
/*
*----------------------------------------------------------------------
*
* Tcl_PkgProvide / Tcl_PkgProvideEx --
*
* This procedure is invoked to declare that a particular version
| > > > > > > > > > > > > > > > > > > > > > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
ClientData clientData; /* Client data. */
} Package;
/*
* Prototypes for procedures defined in this file:
*/
#ifndef TCL_TIP268
static int CheckVersion _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *string));
static int ComparePkgVersions _ANSI_ARGS_((CONST char *v1,
CONST char *v2,
int *satPtr));
static Package * FindPackage _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *name));
#else
static int CheckVersionAndConvert(Tcl_Interp *interp, CONST char *string,
char** internal, int* stable);
static int CompareVersions(CONST char *v1i, CONST char *v2i,
int *isMajorPtr);
static int CheckRequirement(Tcl_Interp *interp, CONST char *string);
static int CheckAllRequirements(Tcl_Interp* interp,
int reqc, Tcl_Obj *CONST reqv[]);
static int RequirementSatisfied(CONST char *havei, CONST char *req);
static int AllRequirementsSatisfied(CONST char *havei,
int reqc, Tcl_Obj *CONST reqv[]);
static void AddRequirementsToResult(Tcl_Interp* interp,
int reqc, Tcl_Obj *CONST reqv[]);
static void AddRequirementsToDString(Tcl_DString* dstring,
int reqc, Tcl_Obj *CONST reqv[]);
static Package * FindPackage(Tcl_Interp *interp, CONST char *name);
static Tcl_Obj* ExactRequirement(CONST char* version);
static void VersionCleanupProc(ClientData clientData,
Tcl_Interp *interp);
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_PkgProvide / Tcl_PkgProvideEx --
*
* This procedure is invoked to declare that a particular version
|
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | * the interpreter. * *---------------------------------------------------------------------- */ int Tcl_PkgProvide(interp, name, version) | | | | | | | | | > > > > > > > > > > > > > > > > > > > > | | | 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
* the interpreter.
*
*----------------------------------------------------------------------
*/
int
Tcl_PkgProvide(interp, name, version)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of package. */
CONST char *version; /* Version string for package. */
{
return Tcl_PkgProvideEx(interp, name, version, (ClientData) NULL);
}
int
Tcl_PkgProvideEx(interp, name, version, clientData)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of package. */
CONST char *version; /* Version string for package. */
ClientData clientData; /* clientdata for this package (normally
* used for C callback function table) */
{
Package *pkgPtr;
#ifdef TCL_TIP268
char* pvi;
char* vi;
int res;
#endif
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version == NULL) {
pkgPtr->version = ckalloc((unsigned) (strlen(version) + 1));
strcpy(pkgPtr->version, version);
pkgPtr->clientData = clientData;
return TCL_OK;
}
#ifndef TCL_TIP268
if (ComparePkgVersions(pkgPtr->version, version, (int *) NULL) == 0) {
#else
if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
return TCL_ERROR;
} else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {
Tcl_Free (pvi);
return TCL_ERROR;
}
res = CompareVersions(pvi, vi, NULL);
Tcl_Free (pvi);
Tcl_Free (vi);
if (res == 0) {
#endif
if (clientData != NULL) {
pkgPtr->clientData = clientData;
}
return TCL_OK;
}
Tcl_AppendResult(interp, "conflicting versions provided for package \"",
name, "\": ", pkgPtr->version, ", then ", version, (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgRequire / Tcl_PkgRequireEx / Tcl_PkgRequireProc --
*
* This procedure is called by code that depends on a particular
* version of a particular package. If the package is not already
* provided in the interpreter, this procedure invokes a Tcl script
* to provide it. If the package is already provided, this
* procedure makes sure that the caller's needs don't conflict with
* the version that is present.
|
| ︙ | ︙ | |||
144 145 146 147 148 149 150 151 152 153 | * * Side effects: * The script from some previous "package ifneeded" command may * be invoked to provide the package. * *---------------------------------------------------------------------- */ CONST char * Tcl_PkgRequire(interp, name, version, exact) | > > > > > > > > > > > > > > > > > | | | | < | | | | | | | | > > > > > | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
*
* Side effects:
* The script from some previous "package ifneeded" command may
* be invoked to provide the package.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_TIP268
/*
* Empty definition for Stubs when TIP 268 is not activated.
*/
int
Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
int reqc; /* Requirements constraining the desired version. */
Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
ClientData *clientDataPtr;
{
return TCL_ERROR;
}
#endif
CONST char *
Tcl_PkgRequire(interp, name, version, exact)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
CONST char *version; /* Version string for desired version; NULL
* means use the latest version available. */
int exact; /* Non-zero means that only the particular
* version given is acceptable. Zero means use
* the latest compatible version. */
{
return Tcl_PkgRequireEx(interp, name, version, exact, (ClientData *) NULL);
}
CONST char *
Tcl_PkgRequireEx(interp, name, version, exact, clientDataPtr)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
* version given is acceptable. Zero means
* use the latest compatible version. */
ClientData *clientDataPtr; /* Used to return the client data for this
* package. If it is NULL then the client
* data is not returned. This is unchanged
* if this call fails for any reason. */
{
#ifndef TCL_TIP268
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr;
char *script;
int code, satisfies, result, pass;
Tcl_DString command;
#else
Tcl_Obj *ov;
int res;
#endif
/*
* If an attempt is being made to load this into a standalone executable
* on a platform where backlinking is not supported then this must be
* a shared version of Tcl (Otherwise the load would have failed).
* Detect this situation by checking that this library has been correctly
* initialised. If it has not been then return immediately as nothing will
|
| ︙ | ︙ | |||
253 254 255 256 257 258 259 |
* are not remedied, so be very careful about adding any other calls
* here without checking how they behave when initialization is
* incomplete.
*/
tclEmptyStringRep = &tclEmptyString;
Tcl_AppendResult(interp, "Cannot load package \"", name,
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | > > > > > > > > > > > > > > > > > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > | | | > > > | < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > | > | > > > > > > > | | < < > > > > | | > > > > | | > > > > > > > | > > > > > > > > > > > > | > | > > > > > | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 |
* are not remedied, so be very careful about adding any other calls
* here without checking how they behave when initialization is
* incomplete.
*/
tclEmptyStringRep = &tclEmptyString;
Tcl_AppendResult(interp, "Cannot load package \"", name,
"\" in standalone executable: This package is not ",
"compiled with stub support", NULL);
return NULL;
}
#ifdef TCL_TIP268
/* Translate between old and new API, and defer to the new function. */
if (version == NULL) {
res = Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr);
} else {
if (exact) {
ov = ExactRequirement (version);
} else {
ov = Tcl_NewStringObj (version,-1);
}
Tcl_IncrRefCount (ov);
res = Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr);
Tcl_DecrRefCount (ov);
}
if (res != TCL_OK) {
return NULL;
}
/* This function returns the version string explictly, and leaves the
* interpreter result empty. However "Tcl_PkgRequireProc" above returned
* the version through the interpreter result. Simply resetting the result
* now potentially deletes the string (obj), and the pointer to its string
* rep we have, as our result, may be dangling due to this. Our solution
* is to remember the object in interp associated data, with a proper
* reference count, and then reset the result. Now pointers will not
* dangle. It will be a leak however if nothing is done. So the next time
* we come through here we delete the object remembered by this call, as
* we can then be sure that there is no pointer to its string around
* anymore. Beyond that we have a deletion function which cleans up the last
* remembered object which was not cleaned up directly, here.
*/
ov = (Tcl_Obj*) Tcl_GetAssocData (interp, "tcl/Tcl_PkgRequireEx", NULL);
if (ov != NULL) {
Tcl_DecrRefCount (ov);
}
ov = Tcl_GetObjResult (interp);
Tcl_IncrRefCount (ov);
Tcl_SetAssocData(interp, "tcl/Tcl_PkgRequireEx", VersionCleanupProc,
(ClientData) ov);
Tcl_ResetResult (interp);
return Tcl_GetString (ov);
}
int
Tcl_PkgRequireProc(interp,name,reqc,reqv,clientDataPtr)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
int reqc; /* Requirements constraining the desired version. */
Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
ClientData *clientDataPtr;
{
Interp *iPtr = (Interp *) interp;
Package *pkgPtr;
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion; /* Internal rep. of versions */
int availStable;
char *script;
int code, satisfies, pass;
Tcl_DString command;
char* pkgVersionI;
#endif
/*
* It can take up to three passes to find the package: one pass to run the
* "package unknown" script, one to run the "package ifneeded" script for
* a specific version, and a final pass to lookup the package loaded by
* the "package ifneeded" script.
*/
for (pass = 1; ; pass++) {
pkgPtr = FindPackage(interp, name);
if (pkgPtr->version != NULL) {
break;
}
/*
* Check whether we're already attempting to load some version
* of this package (circular dependency detection).
*/
if (pkgPtr->clientData != NULL) {
Tcl_AppendResult(interp, "circular package dependency: ",
"attempt to provide ", name, " ",
(char *)(pkgPtr->clientData), " requires ", name, NULL);
#ifndef TCL_TIP268
if (version != NULL) {
Tcl_AppendResult(interp, " ", version, NULL);
}
return NULL;
#else
AddRequirementsToResult (interp, reqc, reqv);
return TCL_ERROR;
#endif
}
/*
* The package isn't yet present. Search the list of available
* versions and invoke the script for the best available version.
*
* For TIP 268 we are actually locating the best, and the best stable
* version. One of them is then chosen based on the selection mode.
*/
#ifndef TCL_TIP268
bestPtr = NULL;
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
if ((bestPtr != NULL) && (ComparePkgVersions(availPtr->version,
bestPtr->version, (int *) NULL) <= 0)) {
#else
bestPtr = NULL;
bestStablePtr = NULL;
bestVersion = NULL;
for (availPtr = pkgPtr->availPtr;
availPtr != NULL;
availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert (interp, availPtr->version,
&availVersion, &availStable) != TCL_OK) {
/* The provided version number is has invalid syntax. This
* should not happen. This should have been caught by the
* 'package ifneeded' registering the package.
*/
#endif
continue;
}
#ifndef TCL_TIP268
if (version != NULL) {
result = ComparePkgVersions(availPtr->version, version,
&satisfies);
if ((result != 0) && exact) {
#else
if (bestPtr != NULL) {
int res = CompareVersions (availVersion, bestVersion, NULL);
/* Note: Use internal reps! */
if (res <= 0) {
/* The version of the package sought is not as good as the
* currently selected version. Ignore it. */
Tcl_Free (availVersion);
availVersion = NULL;
#endif
continue;
}
#ifdef TCL_TIP268
}
/* We have found a version which is better than our max. */
if (reqc > 0) {
/* Check satisfaction of requirements */
satisfies = AllRequirementsSatisfied (availVersion, reqc, reqv);
#endif
if (!satisfies) {
#ifdef TCL_TIP268
Tcl_Free (availVersion);
availVersion = NULL;
#endif
continue;
}
}
bestPtr = availPtr;
#ifdef TCL_TIP268
if (bestVersion != NULL) Tcl_Free (bestVersion);
bestVersion = availVersion;
availVersion = NULL;
/* If this new best version is stable then it also has to be
* better than the max stable version found so far.
*/
if (availStable) {
bestStablePtr = availPtr;
}
}
if (bestVersion != NULL) {
Tcl_Free (bestVersion);
}
/* Now choose a version among the two best. For 'latest' we simply
* take (actually keep) the best. For 'stable' we take the best
* stable, if there is any, or the best if there is nothing stable.
*/
if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) {
bestPtr = bestStablePtr;
#endif
}
if (bestPtr != NULL) {
/*
* We found an ifneeded script for the package. Be careful while
* executing it: this could cause reentrancy, so (a) protect the
* script itself from deletion and (b) don't assume that bestPtr
* will still exist when the script completes.
*/
CONST char *versionToProvide = bestPtr->version;
script = bestPtr->script;
pkgPtr->clientData = (ClientData) versionToProvide;
Tcl_Preserve((ClientData) script);
Tcl_Preserve((ClientData) versionToProvide);
code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
Tcl_Release((ClientData) script);
pkgPtr = FindPackage(interp, name);
if (code == TCL_OK) {
#ifdef TCL_TIP268
Tcl_ResetResult(interp);
#endif
if (pkgPtr->version == NULL) {
#ifndef TCL_TIP268
Tcl_ResetResult(interp);
#endif
code = TCL_ERROR;
Tcl_AppendResult(interp, "attempt to provide package ",
name, " ", versionToProvide,
" failed: no version of package ", name,
" provided", NULL);
#ifndef TCL_TIP268
} else if (0 != ComparePkgVersions(
pkgPtr->version, versionToProvide, NULL)) {
/* At this point, it is clear that a prior
* [package ifneeded] command lied to us. It said
* that to get a particular version of a particular
* package, we needed to evaluate a particular script.
* However, we evaluated that script and got a different
* version than we were told. This is an error, and we
* ought to report it.
*
* However, we've been letting this type of error slide
* for a long time, and as a result, a lot of packages
* suffer from them.
*
* It's a bit too harsh to make a large number of
* existing packages start failing by releasing a
* new patch release, so we forgive this type of error
* for the rest of the Tcl 8.4 series.
*
* We considered reporting a warning, but in practice
* even that appears too harsh a change for a patch release.
*
* We limit the error reporting to only
* the situation where a broken ifneeded script leads
* to a failure to satisfy the requirement.
*/
if (version) {
result = ComparePkgVersions(
pkgPtr->version, version, &satisfies);
if (result && (exact || !satisfies)) {
Tcl_ResetResult(interp);
code = TCL_ERROR;
Tcl_AppendResult(interp,
"attempt to provide package ", name, " ",
versionToProvide, " failed: package ",
name, " ", pkgPtr->version,
" provided instead", NULL);
#else
} else {
char* pvi;
char* vi;
int res;
if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
code = TCL_ERROR;
} else if (CheckVersionAndConvert (interp, versionToProvide, &vi, NULL) != TCL_OK) {
Tcl_Free (pvi);
code = TCL_ERROR;
} else {
res = CompareVersions(pvi, vi, NULL);
Tcl_Free (vi);
if (res != 0) {
/* At this point, it is clear that a prior
* [package ifneeded] command lied to us. It said
* that to get a particular version of a particular
* package, we needed to evaluate a particular script.
* However, we evaluated that script and got a different
* version than we were told. This is an error, and we
* ought to report it.
*
* However, we've been letting this type of error slide
* for a long time, and as a result, a lot of packages
* suffer from them.
*
* It's a bit too harsh to make a large number of
* existing packages start failing by releasing a
* new patch release, so we forgive this type of error
* for the rest of the Tcl 8.4 series.
*
* We considered reporting a warning, but in practice
* even that appears too harsh a change for a patch release.
*
* We limit the error reporting to only
* the situation where a broken ifneeded script leads
* to a failure to satisfy the requirement.
*/
if (reqc > 0) {
satisfies = AllRequirementsSatisfied (pvi, reqc, reqv);
if (!satisfies) {
Tcl_ResetResult(interp);
code = TCL_ERROR;
Tcl_AppendResult(interp,
"attempt to provide package ", name, " ",
versionToProvide, " failed: package ",
name, " ", pkgPtr->version,
" provided instead", NULL);
}
}
/*
* Warning generation now disabled
if (code == TCL_OK) {
Tcl_Obj *msg = Tcl_NewStringObj(
"attempt to provide package ", -1);
Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, cmdPtr,
Tcl_NewStringObj("tclLog", -1));
Tcl_AppendStringsToObj(msg, name, " ", versionToProvide,
" failed: package ", name, " ",
pkgPtr->version, " provided instead", NULL);
Tcl_ListObjAppendElement(NULL, cmdPtr, msg);
Tcl_IncrRefCount(cmdPtr);
Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmdPtr);
Tcl_ResetResult(interp);
}
*/
#endif
}
#ifdef TCL_TIP268
Tcl_Free (pvi);
#endif
}
#ifndef TCL_TIP268
/*
* Warning generation now disabled
if (code == TCL_OK) {
Tcl_Obj *msg = Tcl_NewStringObj(
"attempt to provide package ", -1);
Tcl_Obj *cmdPtr = Tcl_NewListObj(0, NULL);
Tcl_ListObjAppendElement(NULL, cmdPtr,
Tcl_NewStringObj("tclLog", -1));
Tcl_AppendStringsToObj(msg, name, " ", versionToProvide,
" failed: package ", name, " ",
pkgPtr->version, " provided instead", NULL);
Tcl_ListObjAppendElement(NULL, cmdPtr, msg);
Tcl_IncrRefCount(cmdPtr);
Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmdPtr);
Tcl_ResetResult(interp);
}
*/
#endif
}
} else if (code != TCL_ERROR) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "attempt to provide package ",
name, " ", versionToProvide, " failed: ",
"bad return code: ", Tcl_GetString(codePtr), NULL);
Tcl_DecrRefCount(codePtr);
code = TCL_ERROR;
}
Tcl_Release((ClientData) versionToProvide);
if (code != TCL_OK) {
/*
* Take a non-TCL_OK code from the script as an
* indication the package wasn't loaded properly,
* so the package system should not remember an
* improper load.
*
* This is consistent with our returning NULL.
* If we're not willing to tell our caller we
* got a particular version, we shouldn't store
* that version for telling future callers either.
*/
Tcl_AddErrorInfo(interp, "\n (\"package ifneeded\" script)");
if (pkgPtr->version != NULL) {
ckfree(pkgPtr->version);
pkgPtr->version = NULL;
}
pkgPtr->clientData = NULL;
#ifndef TCL_TIP268
return NULL;
#else
return TCL_ERROR;
#endif
}
break;
}
/*
* The package is not in the database. If there is a "package unknown"
* command, invoke it (but only on the first pass; after that, we
* should not get here in the first place).
*/
if (pass > 1) {
break;
}
script = ((Interp *) interp)->packageUnknown;
if (script != NULL) {
Tcl_DStringInit(&command);
Tcl_DStringAppend(&command, script, -1);
Tcl_DStringAppendElement(&command, name);
#ifndef TCL_TIP268
Tcl_DStringAppend(&command, " ", 1);
Tcl_DStringAppend(&command, (version != NULL) ? version : "{}",
-1);
if (exact) {
Tcl_DStringAppend(&command, " -exact", 7);
}
#else
AddRequirementsToDString(&command, reqc, reqv);
#endif
code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
Tcl_DStringFree(&command);
if ((code != TCL_OK) && (code != TCL_ERROR)) {
Tcl_Obj *codePtr = Tcl_NewIntObj(code);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "bad return code: ",
Tcl_GetString(codePtr), NULL);
Tcl_DecrRefCount(codePtr);
code = TCL_ERROR;
}
if (code == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)");
#ifndef TCL_TIP268
return NULL;
#else
return TCL_ERROR;
#endif
}
Tcl_ResetResult(interp);
}
}
if (pkgPtr->version == NULL) {
Tcl_AppendResult(interp, "can't find package ", name, (char *) NULL);
#ifndef TCL_TIP268
if (version != NULL) {
Tcl_AppendResult(interp, " ", version, (char *) NULL);
}
return NULL;
#else
AddRequirementsToResult(interp, reqc, reqv);
return TCL_ERROR;
#endif
}
/*
* At this point we know that the package is present. Make sure that the
* provided version meets the current requirements.
*/
#ifndef TCL_TIP268
if (version == NULL) {
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
return pkgPtr->version;
#else
if (reqc == 0) {
satisfies = 1;
} else {
CheckVersionAndConvert (interp, pkgPtr->version, &pkgVersionI, NULL);
satisfies = AllRequirementsSatisfied (pkgVersionI, reqc, reqv);
Tcl_Free (pkgVersionI);
#endif
}
#ifndef TCL_TIP268
result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
if ((satisfies && !exact) || (result == 0)) {
#else
if (satisfies) {
#endif
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
#ifndef TCL_TIP268
return pkgPtr->version;
#else
Tcl_SetObjResult (interp, Tcl_NewStringObj (pkgPtr->version, -1));
return TCL_OK;
#endif
}
Tcl_AppendResult(interp, "version conflict for package \"",
name, "\": have ", pkgPtr->version,
#ifndef TCL_TIP268
", need ", version, (char *) NULL);
return NULL;
#else
", need", (char*) NULL);
AddRequirementsToResult (interp, reqc, reqv);
return TCL_ERROR;
#endif
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgPresent / Tcl_PkgPresentEx --
*
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 | * None. * *---------------------------------------------------------------------- */ CONST char * Tcl_PkgPresent(interp, name, version, exact) | | | | | | | | | | > > > > > > > > > > > > > > > > > > | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 |
* None.
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_PkgPresent(interp, name, version, exact)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
* version given is acceptable. Zero means
* use the latest compatible version. */
{
return Tcl_PkgPresentEx(interp, name, version, exact, (ClientData *) NULL);
}
CONST char *
Tcl_PkgPresentEx(interp, name, version, exact, clientDataPtr)
Tcl_Interp *interp; /* Interpreter in which package is now
* available. */
CONST char *name; /* Name of desired package. */
CONST char *version; /* Version string for desired version;
* NULL means use the latest version
* available. */
int exact; /* Non-zero means that only the particular
* version given is acceptable. Zero means
* use the latest compatible version. */
ClientData *clientDataPtr; /* Used to return the client data for this
* package. If it is NULL then the client
* data is not returned. This is unchanged
* if this call fails for any reason. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Package *pkgPtr;
int satisfies, result;
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
#ifdef TCL_TIP268
char* pvi;
char* vi;
int thisIsMajor;
#endif
/*
* At this point we know that the package is present. Make sure
* that the provided version meets the current requirement.
*/
if (version == NULL) {
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
return pkgPtr->version;
}
#ifndef TCL_TIP268
result = ComparePkgVersions(pkgPtr->version, version, &satisfies);
#else
if (CheckVersionAndConvert (interp, pkgPtr->version, &pvi, NULL) != TCL_OK) {
return NULL;
} else if (CheckVersionAndConvert (interp, version, &vi, NULL) != TCL_OK) {
Tcl_Free (pvi);
return NULL;
}
result = CompareVersions(pvi, vi, &thisIsMajor);
Tcl_Free (pvi);
Tcl_Free (vi);
satisfies = (result == 0) || ((result == 1) && !thisIsMajor);
#endif
if ((satisfies && !exact) || (result == 0)) {
if (clientDataPtr) {
*clientDataPtr = pkgPtr->clientData;
}
return pkgPtr->version;
}
|
| ︙ | ︙ | |||
502 503 504 505 506 507 508 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | | | | | | | > > > > | | > > > | > > > > | > | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_PackageObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *pkgOptions[] = {
"forget", "ifneeded", "names",
#ifdef TCL_TIP268
"prefer",
#endif
"present", "provide", "require", "unknown", "vcompare",
"versions", "vsatisfies", (char *) NULL
};
enum pkgOptions {
PKG_FORGET, PKG_IFNEEDED, PKG_NAMES,
#ifdef TCL_TIP268
PKG_PREFER,
#endif
PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
PKG_VERSIONS, PKG_VSATISFIES
};
Interp *iPtr = (Interp *) interp;
int optionIndex, exact, i, satisfies;
PkgAvail *availPtr, *prevPtr;
Package *pkgPtr;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_HashTable *tablePtr;
CONST char *version;
char *argv2, *argv3, *argv4;
#ifdef TCL_TIP268
char* iva = NULL;
char* ivb = NULL;
#endif
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum pkgOptions) optionIndex) {
#ifndef TCL_TIP268
case PKG_FORGET: {
char *keyString;
for (i = 2; i < objc; i++) {
keyString = Tcl_GetString(objv[i]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
continue;
}
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (pkgPtr->version != NULL) {
ckfree(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
ckfree((char *) availPtr);
}
ckfree((char *) pkgPtr);
}
break;
#else
case PKG_FORGET: {
char *keyString;
for (i = 2; i < objc; i++) {
keyString = Tcl_GetString(objv[i]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
continue;
}
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (pkgPtr->version != NULL) {
ckfree(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
ckfree((char *) availPtr);
}
ckfree((char *) pkgPtr);
}
break;
}
case PKG_IFNEEDED: {
int length;
char* argv3i;
char* avi;
int res;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
return TCL_ERROR;
}
argv3 = Tcl_GetString(objv[3]);
if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) {
return TCL_ERROR;
#endif
}
#ifndef TCL_TIP268
case PKG_IFNEEDED: {
int length;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
return TCL_ERROR;
#else
argv2 = Tcl_GetString(objv[2]);
if (objc == 4) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr == NULL) {
Tcl_Free (argv3i);
return TCL_OK;
#endif
}
#ifndef TCL_TIP268
argv3 = Tcl_GetString(objv[3]);
if (CheckVersion(interp, argv3) != TCL_OK) {
#else
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL;
availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert (interp, availPtr->version, &avi, NULL) != TCL_OK) {
Tcl_Free (argv3i);
#endif
return TCL_ERROR;
}
#ifndef TCL_TIP268
argv2 = Tcl_GetString(objv[2]);
if (objc == 4) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr == NULL) {
#else
res = CompareVersions(avi, argv3i, NULL);
Tcl_Free (avi);
if (res == 0){
if (objc == 4) {
Tcl_Free (argv3i);
Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
#endif
return TCL_OK;
}
#ifndef TCL_TIP268
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
argv3 = Tcl_GetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
if (ComparePkgVersions(availPtr->version, argv3, (int *) NULL)
== 0) {
if (objc == 4) {
Tcl_SetResult(interp, availPtr->script, TCL_VOLATILE);
return TCL_OK;
}
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
break;
}
}
if (objc == 4) {
return TCL_OK;
#else
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
break;
#endif
}
#ifndef TCL_TIP268
if (availPtr == NULL) {
availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
availPtr->version = ckalloc((unsigned) (length + 1));
strcpy(availPtr->version, argv3);
if (prevPtr == NULL) {
availPtr->nextPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr;
} else {
availPtr->nextPtr = prevPtr->nextPtr;
prevPtr->nextPtr = availPtr;
}
#else
}
Tcl_Free (argv3i);
if (objc == 4) {
return TCL_OK;
}
if (availPtr == NULL) {
availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
availPtr->version = ckalloc((unsigned) (length + 1));
strcpy(availPtr->version, argv3);
if (prevPtr == NULL) {
availPtr->nextPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr;
} else {
availPtr->nextPtr = prevPtr->nextPtr;
prevPtr->nextPtr = availPtr;
#endif
}
#ifndef TCL_TIP268
argv4 = Tcl_GetStringFromObj(objv[4], &length);
availPtr->script = ckalloc((unsigned) (length + 1));
strcpy(availPtr->script, argv4);
break;
#endif
}
#ifndef TCL_TIP268
case PKG_NAMES: {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
#else
argv4 = Tcl_GetStringFromObj(objv[4], &length);
availPtr->script = ckalloc((unsigned) (length + 1));
strcpy(availPtr->script, argv4);
break;
}
case PKG_NAMES: {
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
}
}
break;
}
case PKG_PRESENT: {
if (objc < 3) {
presentSyntax:
Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
return TCL_ERROR;
}
argv2 = Tcl_GetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
exact = 1;
} else {
exact = 0;
}
version = NULL;
if (objc == (4 + exact)) {
version = Tcl_GetString(objv[3 + exact]);
if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
#endif
return TCL_ERROR;
}
#ifndef TCL_TIP268
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
#else
} else if ((objc != 3) || exact) {
goto presentSyntax;
}
if (exact) {
argv3 = Tcl_GetString(objv[3]);
version = Tcl_PkgPresent(interp, argv3, version, exact);
} else {
version = Tcl_PkgPresent(interp, argv2, version, exact);
}
if (version == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
break;
}
case PKG_PROVIDE: {
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
return TCL_ERROR;
}
argv2 = Tcl_GetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
#endif
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
#ifndef TCL_TIP268
if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
#else
if (pkgPtr->version != NULL) {
Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
#endif
}
}
#ifndef TCL_TIP268
break;
#else
return TCL_OK;
#endif
}
#ifndef TCL_TIP268
case PKG_PRESENT: {
if (objc < 3) {
presentSyntax:
Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
return TCL_ERROR;
#else
argv3 = Tcl_GetString(objv[3]);
if (CheckVersionAndConvert(interp, argv3, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgProvide(interp, argv2, argv3);
}
case PKG_REQUIRE: {
if (objc < 3) {
requireSyntax:
Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?requirement...?");
return TCL_ERROR;
}
version = NULL;
argv2 = Tcl_GetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
Tcl_Obj* ov;
int res;
if (objc != 5) {
goto requireSyntax;
#endif
}
#ifndef TCL_TIP268
argv2 = Tcl_GetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
exact = 1;
} else {
exact = 0;
#else
version = Tcl_GetString(objv[4]);
if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) {
return TCL_ERROR;
#endif
}
#ifdef TCL_TIP268
/* Create a new-style requirement for the exact version. */
ov = ExactRequirement (version);
#endif
version = NULL;
#ifndef TCL_TIP268
if (objc == (4 + exact)) {
version = Tcl_GetString(objv[3 + exact]);
if (CheckVersion(interp, version) != TCL_OK) {
return TCL_ERROR;
}
} else if ((objc != 3) || exact) {
goto presentSyntax;
}
if (exact) {
argv3 = Tcl_GetString(objv[3]);
version = Tcl_PkgPresent(interp, argv3, version, exact);
} else {
version = Tcl_PkgPresent(interp, argv2, version, exact);
}
if (version == NULL) {
#else
argv3 = Tcl_GetString(objv[3]);
Tcl_IncrRefCount (ov);
res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
Tcl_DecrRefCount (ov);
return res;
} else {
if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) {
#endif
return TCL_ERROR;
}
#ifndef TCL_TIP268
Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
break;
#else
return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);
#endif
}
#ifndef TCL_TIP268
case PKG_PROVIDE: {
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
#else
break;
}
case PKG_UNKNOWN: {
int length;
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
argv2 = Tcl_GetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
iPtr->packageUnknown = (char *) ckalloc((unsigned)
(length + 1));
strcpy(iPtr->packageUnknown, argv2);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?command?");
return TCL_ERROR;
}
break;
}
case PKG_PREFER: {
/* See tclInt.h for the enum, just before Interp */
static CONST char *pkgPreferOptions[] = {
"latest", "stable", NULL
};
if (objc > 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?latest|stable?");
return TCL_ERROR;
} else if (objc == 3) {
/* Set value. */
int new;
if (Tcl_GetIndexFromObj(interp, objv[2], pkgPreferOptions, "preference", 0,
&new) != TCL_OK) {
#endif
return TCL_ERROR;
}
#ifndef TCL_TIP268
argv2 = Tcl_GetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_SetResult(interp, pkgPtr->version, TCL_VOLATILE);
}
}
return TCL_OK;
#else
if (new < iPtr->packagePrefer) {
iPtr->packagePrefer = new;
#endif
}
#ifndef TCL_TIP268
argv3 = Tcl_GetString(objv[3]);
if (CheckVersion(interp, argv3) != TCL_OK) {
return TCL_ERROR;
}
return Tcl_PkgProvide(interp, argv2, argv3);
#endif
}
#ifndef TCL_TIP268
case PKG_REQUIRE: {
if (objc < 3) {
requireSyntax:
Tcl_WrongNumArgs(interp, 2, objv, "?-exact? package ?version?");
return TCL_ERROR;
}
argv2 = Tcl_GetString(objv[2]);
|
| ︙ | ︙ | |||
718 719 720 721 722 723 724 |
version = Tcl_PkgRequire(interp, argv2, version, exact);
}
if (version == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
break;
| > > > > | > > > > > > > | 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 |
version = Tcl_PkgRequire(interp, argv2, version, exact);
}
if (version == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult( interp, Tcl_NewStringObj( version, -1 ) );
break;
#else
/* Always return current value. */
Tcl_SetObjResult(interp, Tcl_NewStringObj (pkgPreferOptions [iPtr->packagePrefer], -1));
break;
}
case PKG_VCOMPARE: {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
return TCL_ERROR;
#endif
}
#ifndef TCL_TIP268
case PKG_UNKNOWN: {
int length;
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
Tcl_SetResult(interp, iPtr->packageUnknown, TCL_VOLATILE);
}
} else if (objc == 3) {
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 |
strcpy(iPtr->packageUnknown, argv2);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?command?");
return TCL_ERROR;
}
break;
}
case PKG_VCOMPARE: {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
return TCL_ERROR;
}
argv3 = Tcl_GetString(objv[3]);
argv2 = Tcl_GetString(objv[2]);
if ((CheckVersion(interp, argv2) != TCL_OK)
|| (CheckVersion(interp, argv3) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp),
ComparePkgVersions(argv2, argv3, (int *) NULL));
break;
| > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > | 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 |
strcpy(iPtr->packageUnknown, argv2);
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?command?");
return TCL_ERROR;
}
break;
#else
argv3 = Tcl_GetString(objv[3]);
argv2 = Tcl_GetString(objv[2]);
if ((CheckVersionAndConvert (interp, argv2, &iva, NULL) != TCL_OK) ||
(CheckVersionAndConvert (interp, argv3, &ivb, NULL) != TCL_OK)) {
if (iva != NULL) { Tcl_Free (iva); }
/* ivb cannot be set in this branch */
return TCL_ERROR;
#endif
}
#ifndef TCL_TIP268
case PKG_VCOMPARE: {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
return TCL_ERROR;
}
argv3 = Tcl_GetString(objv[3]);
argv2 = Tcl_GetString(objv[2]);
if ((CheckVersion(interp, argv2) != TCL_OK)
|| (CheckVersion(interp, argv3) != TCL_OK)) {
return TCL_ERROR;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp),
ComparePkgVersions(argv2, argv3, (int *) NULL));
break;
#else
/* Comparison is done on the internal representation */
Tcl_SetObjResult(interp,Tcl_NewIntObj(CompareVersions(iva, ivb, NULL)));
Tcl_Free (iva);
Tcl_Free (ivb);
break;
}
case PKG_VERSIONS: {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
#endif
}
#ifndef TCL_TIP268
case PKG_VERSIONS: {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
#else
argv2 = Tcl_GetString(objv[2]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
Tcl_AppendElement(interp, availPtr->version);
#endif
}
#ifndef TCL_TIP268
argv2 = Tcl_GetString(objv[2]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
Tcl_AppendElement(interp, availPtr->version);
}
}
break;
#endif
}
#ifndef TCL_TIP268
case PKG_VSATISFIES: {
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "version1 version2");
return TCL_ERROR;
}
argv3 = Tcl_GetString(objv[3]);
argv2 = Tcl_GetString(objv[2]);
if ((CheckVersion(interp, argv2) != TCL_OK)
|| (CheckVersion(interp, argv3) != TCL_OK)) {
return TCL_ERROR;
}
ComparePkgVersions(argv2, argv3, &satisfies);
Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies);
break;
#else
break;
}
case PKG_VSATISFIES: {
char* argv2i = NULL;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "version requirement requirement...");
return TCL_ERROR;
#endif
}
#ifndef TCL_TIP268
default: {
panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
#else
argv2 = Tcl_GetString(objv[2]);
if ((CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK)) {
return TCL_ERROR;
} else if (CheckAllRequirements (interp, objc-3, objv+3) != TCL_OK) {
Tcl_Free (argv2i);
return TCL_ERROR;
#endif
}
#ifdef TCL_TIP268
satisfies = AllRequirementsSatisfied (argv2i, objc-3, objv+3);
Tcl_Free (argv2i);
Tcl_SetIntObj(Tcl_GetObjResult(interp), satisfies);
break;
}
default: {
panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
}
#endif
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
817 818 819 820 821 822 823 | * A new Package record may be created. * *---------------------------------------------------------------------- */ static Package * FindPackage(interp, name) | | | | 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 |
* A new Package record may be created.
*
*----------------------------------------------------------------------
*/
static Package *
FindPackage(interp, name)
Tcl_Interp *interp; /* Interpreter to use for package lookup. */
CONST char *name; /* Name of package to fine. */
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int new;
Package *pkgPtr;
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &new);
|
| ︙ | ︙ | |||
858 859 860 861 862 863 864 | * Memory is freed. * *---------------------------------------------------------------------- */ void TclFreePackageInfo(iPtr) | | | | | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | > > > > > > > > > > > > | | | > | > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 |
* Memory is freed.
*
*----------------------------------------------------------------------
*/
void
TclFreePackageInfo(iPtr)
Interp *iPtr; /* Interpreter that is being deleted. */
{
Package *pkgPtr;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
PkgAvail *availPtr;
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = (Package *) Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
ckfree(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree((ClientData)availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree((ClientData)availPtr->script, TCL_DYNAMIC);
ckfree((char *) availPtr);
}
ckfree((char *) pkgPtr);
}
Tcl_DeleteHashTable(&iPtr->packageTable);
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
}
/*
*----------------------------------------------------------------------
*
* CheckVersion / CheckVersionAndConvert --
*
* This procedure checks to see whether a version number has
* valid syntax.
*
* Results:
* If string is a properly formed version number the TCL_OK
* is returned. Otherwise TCL_ERROR is returned and an error
* message is left in the interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
#ifndef TCL_TIP268
CheckVersion(interp, string)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *string; /* Supposedly a version number, which is
* groups of decimal digits separated
* by dots. */
#else
CheckVersionAndConvert(interp, string, internal, stable)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *string; /* Supposedly a version number, which is
* groups of decimal digits separated by
* dots. */
char** internal; /* Internal normalized representation */
int* stable; /* Flag: Version is (un)stable. */
#endif
{
CONST char *p = string;
char prevChar;
#ifdef TCL_TIP268
int hasunstable = 0;
/* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
char* ibuf = ckalloc (4+4*strlen(string));
char* ip = ibuf;
/* Basic rules
* (1) First character has to be a digit.
* (2) All other characters have to be a digit or '.'
* (3) Two '.'s may not follow each other.
* TIP 268, Modified rules
* (1) s.a.
* (2) All other characters have to be a digit, 'a', 'b', or '.'
* (3) s.a.
* (4) Only one of 'a' or 'b' may occur.
* (5) Neither 'a', nor 'b' may occur before or after a '.'
*/
#endif
if (!isdigit(UCHAR(*p))) { /* INTL: digit */
goto error;
}
#ifdef TCL_TIP268
*ip++ = *p;
#endif
for (prevChar = *p, p++; *p != 0; p++) {
#ifndef TCL_TIP268
if (!isdigit(UCHAR(*p)) &&
((*p != '.') || (prevChar == '.'))) { /* INTL: digit */
#else
if (
(!isdigit(UCHAR(*p))) &&
(((*p != '.') && (*p != 'a') && (*p != 'b')) ||
((hasunstable && ((*p == 'a') || (*p == 'b'))) ||
(((prevChar == 'a') || (prevChar == 'b') || (prevChar == '.')) && (*p == '.')) ||
(((*p == 'a') || (*p == 'b') || (*p == '.')) && (prevChar == '.'))))
) {
/* INTL: digit */
#endif
goto error;
}
#ifdef TCL_TIP268
if ((*p == 'a') || (*p == 'b')) { hasunstable = 1 ; }
/* Translation to the internal rep. Regular version chars are copied
* as is. The separators are translated to numerics. The new separator
* for all parts is space. */
if (*p == '.') { *ip++ = ' '; *ip++ = '0'; *ip++ = ' '; }
else if (*p == 'a') { *ip++ = ' '; *ip++ = '-'; *ip++ = '2'; *ip++ = ' '; }
else if (*p == 'b') { *ip++ = ' '; *ip++ = '-'; *ip++ = '1'; *ip++ = ' '; }
else { *ip++ = *p; }
#endif
prevChar = *p;
}
#ifndef TCL_TIP268
if (prevChar != '.') {
#else
if ((prevChar != '.') && (prevChar != 'a') && (prevChar != 'b')) {
*ip = '\0';
if (internal != NULL) {
*internal = ibuf;
} else {
Tcl_Free (ibuf);
}
if (stable != NULL) {
*stable = !hasunstable;
}
#endif
return TCL_OK;
}
error:
#ifdef TCL_TIP268
ckfree (ibuf);
#endif
Tcl_AppendResult(interp, "expected version number but got \"",
string, "\"", (char *) NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ComparePkgVersions / CompareVersions --
*
* This procedure compares two version numbers. (268: in internal rep).
*
* Results:
* The return value is -1 if v1 is less than v2, 0 if the two
* version numbers are the same, and 1 if v1 is greater than v2.
* If *satPtr is non-NULL, the word it points to is filled in
* with 1 if v2 >= v1 and both numbers have the same major number
* or 0 otherwise.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
#ifndef TCL_TIP268
ComparePkgVersions(v1, v2, satPtr)
CONST char *v1;
CONST char *v2; /* Versions strings, of form 2.1.3 (any
* number of version numbers). */
int *satPtr; /* If non-null, the word pointed to is
* filled in with a 0/1 value. 1 means
* v1 "satisfies" v2: v1 is greater than
* or equal to v2 and both version numbers
* have the same major number. */
#else
CompareVersions(v1, v2, isMajorPtr)
CONST char *v1; /* Versions strings, of form 2.1.3 (any number */
CONST char *v2; /* of version numbers). */
int *isMajorPtr; /* If non-null, the word pointed to is filled
* in with a 0/1 value. 1 means that the difference
* occured in the first element. */
#endif
{
int thisIsMajor, n1, n2;
#ifdef TCL_TIP268
int res, flip;
#endif
/*
* Each iteration of the following loop processes one number from each
* string, terminated by a " " (space). If those numbers don't match then the
* comparison is over; otherwise, we loop back for the next number.
*
* TIP 268.
* This is identical the function 'ComparePkgVersion', but using the new
* space separator as used by the internal rep of version numbers. The
* special separators 'a' and 'b' have already been dealt with in
* 'CheckVersionAndConvert', they were translated into numbers as
* well. This keeps the comparison sane. Otherwise we would have to
* compare numerics, the separators, and also deal with the special case
* of end-of-string compared to separators. The semi-list rep we get here
* is much easier to handle, as it is still regular.
*/
thisIsMajor = 1;
while (1) {
/*
* Parse one decimal number from the front of each string.
*/
n1 = n2 = 0;
#ifndef TCL_TIP268
while ((*v1 != 0) && (*v1 != '.')) {
#else
flip = 0;
while ((*v1 != 0) && (*v1 != ' ')) {
if (*v1 == '-') {flip = 1 ; v1++ ; continue;}
#endif
n1 = 10*n1 + (*v1 - '0');
v1++;
}
#ifndef TCL_TIP268
while ((*v2 != 0) && (*v2 != '.')) {
#else
if (flip) n1 = -n1;
flip = 0;
while ((*v2 != 0) && (*v2 != ' ')) {
if (*v2 == '-') {flip = 1; v2++ ; continue;}
#endif
n2 = 10*n2 + (*v2 - '0');
v2++;
}
#ifdef TCL_TIP268
if (flip) n2 = -n2;
#endif
/*
* Compare and go on to the next version number if the current numbers
* match.
*/
if (n1 != n2) {
break;
}
if (*v1 != 0) {
v1++;
} else if (*v2 == 0) {
break;
}
if (*v2 != 0) {
v2++;
}
thisIsMajor = 0;
}
#ifndef TCL_TIP268
if (satPtr != NULL) {
*satPtr = (n1 == n2) || ((n1 > n2) && !thisIsMajor);
}
#endif
if (n1 > n2) {
#ifndef TCL_TIP268
return 1;
#else
res = 1;
#endif
} else if (n1 == n2) {
#ifndef TCL_TIP268
return 0;
#else
res = 0;
#endif
} else {
#ifndef TCL_TIP268
return -1;
#else
res = -1;
}
if (isMajorPtr != NULL) {
*isMajorPtr = thisIsMajor;
}
return res;
}
/*
*----------------------------------------------------------------------
*
* CheckAllRequirements --
*
* This function checks to see whether all requirements in a set
* have valid syntax.
*
* Results:
* TCL_OK is returned if all requirements are valid.
* Otherwise TCL_ERROR is returned and an error message
* is left in the interp's result.
*
* Side effects:
* May modify the interpreter result.
*
*----------------------------------------------------------------------
*/
static int
CheckAllRequirements(interp, reqc, reqv)
Tcl_Interp* interp;
int reqc; /* Requirements to check. */
Tcl_Obj *CONST reqv[];
{
int i;
for (i = 0; i < reqc; i++) {
if ((CheckRequirement(interp, Tcl_GetString(reqv[i])) != TCL_OK)) {
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* CheckRequirement --
*
* This function checks to see whether a requirement has valid syntax.
*
* Results:
* If string is a properly formed requirement then TCL_OK is returned.
* Otherwise TCL_ERROR is returned and an error message is left in the
* interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CheckRequirement(interp, string)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *string; /* Supposedly a requirement. */
{
/* Syntax of requirement = version
* = version-version
* = version-
*/
char* dash = NULL;
char* buf;
dash = strchr (string, '-');
if (dash == NULL) {
/* no dash found, has to be a simple version */
return CheckVersionAndConvert (interp, string, NULL, NULL);
}
if (strchr (dash+1, '-') != NULL) {
/* More dashes found after the first. This is wrong. */
Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"", string,
"\"", NULL);
return TCL_ERROR;
#endif
}
#ifdef TCL_TIP268
/* Exactly one dash is present. Copy the string, split at the location of
* dash and check that both parts are versions. Note that the max part can
* be empty.
*/
buf = strdup (string);
dash = buf + (dash - string);
*dash = '\0'; /* buf now <=> min part */
dash ++; /* dash now <=> max part */
if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) ||
((*dash != '\0') &&
(CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) {
free (buf);
return TCL_ERROR;
}
free (buf);
return TCL_OK;
#endif
}
#ifdef TCL_TIP268
/*
*----------------------------------------------------------------------
*
* AddRequirementsToResult --
*
* This function accumulates requirements in the interpreter result.
*
* Results:
* None.
*
* Side effects:
* The interpreter result is extended.
*
*----------------------------------------------------------------------
*/
static void
AddRequirementsToResult(interp, reqc, reqv)
Tcl_Interp* interp;
int reqc; /* Requirements constraining the desired version. */
Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
{
if (reqc > 0) {
int i;
for (i = 0; i < reqc; i++) {
Tcl_AppendResult(interp, " ", TclGetString(reqv[i]), NULL);
}
}
}
/*
*----------------------------------------------------------------------
*
* AddRequirementsToDString --
*
* This function accumulates requirements in a DString.
*
* Results:
* None.
*
* Side effects:
* The DString argument is extended.
*
*----------------------------------------------------------------------
*/
static void
AddRequirementsToDString(dstring, reqc, reqv)
Tcl_DString* dstring;
int reqc; /* Requirements constraining the desired version. */
Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
{
if (reqc > 0) {
int i;
for (i = 0; i < reqc; i++) {
Tcl_DStringAppend(dstring, " ", 1);
Tcl_DStringAppend(dstring, TclGetString(reqv[i]), -1);
}
} else {
Tcl_DStringAppend(dstring, " 0-", -1);
}
}
/*
*----------------------------------------------------------------------
*
* AllRequirementSatisfied --
*
* This function checks to see whether a version satisfies at
* least one of a set of requirements.
*
* Results:
* If the requirements are satisfied 1 is returned.
* Otherwise 0 is returned. The function assumes
* that all pieces have valid syntax. And is allowed
* to make that assumption.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
AllRequirementsSatisfied(availVersionI, reqc, reqv)
CONST char* availVersionI; /* Candidate version to check against the requirements */
int reqc; /* Requirements constraining the desired version. */
Tcl_Obj *CONST reqv[]; /* 0 means to use the latest version available. */
{
int i, satisfies;
for (satisfies = i = 0; i < reqc; i++) {
satisfies = RequirementSatisfied(availVersionI, Tcl_GetString(reqv[i]));
if (satisfies) break;
}
return satisfies;
}
/*
*----------------------------------------------------------------------
*
* RequirementSatisfied --
*
* This function checks to see whether a version satisfies a requirement.
*
* Results:
* If the requirement is satisfied 1 is returned.
* Otherwise 0 is returned. The function assumes
* that all pieces have valid syntax. And is allowed
* to make that assumption.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
RequirementSatisfied(havei, req)
CONST char *havei; /* Version string, of candidate package we have */
CONST char *req; /* Requirement string the candidate has to satisfy */
{
/* The have candidate is already in internal rep. */
int satisfied, res;
char* dash = NULL;
char* buf, *min, *max;
dash = strchr (req, '-');
if (dash == NULL) {
/* No dash found, is a simple version, fallback to regular check.
* The 'CheckVersionAndConvert' cannot fail. We pad the requirement with
* 'a0', i.e '-2' before doing the comparison to properly accept
* unstables as well.
*/
char* reqi = NULL;
int thisIsMajor;
CheckVersionAndConvert (NULL, req, &reqi, NULL);
strcat (reqi, " -2");
res = CompareVersions(havei, reqi, &thisIsMajor);
satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
Tcl_Free (reqi);
return satisfied;
}
/* Exactly one dash is present (Assumption of valid syntax). Copy the req,
* split at the location of dash and check that both parts are
* versions. Note that the max part can be empty.
*/
buf = strdup (req);
dash = buf + (dash - req);
*dash = '\0'; /* buf now <=> min part */
dash ++; /* dash now <=> max part */
if (*dash == '\0') {
/* We have a min, but no max. For the comparison we generate the
* internal rep, padded with 'a0' i.e. '-2'.
*/
/* No max part, unbound */
CheckVersionAndConvert (NULL, buf, &min, NULL);
strcat (min, " -2");
satisfied = (CompareVersions(havei, min, NULL) >= 0);
Tcl_Free (min);
free (buf);
return satisfied;
}
/* We have both min and max, and generate their internal reps.
* When identical we compare as is, otherwise we pad with 'a0'
* to ove the range a bit.
*/
CheckVersionAndConvert (NULL, buf, &min, NULL);
CheckVersionAndConvert (NULL, dash, &max, NULL);
if (CompareVersions(min, max, NULL) == 0) {
satisfied = (CompareVersions(min, havei, NULL) == 0);
} else {
strcat (min, " -2");
strcat (max, " -2");
satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
(CompareVersions(havei, max, NULL) < 0));
}
Tcl_Free (min);
Tcl_Free (max);
free (buf);
return satisfied;
}
/*
*----------------------------------------------------------------------
*
* ExactRequirement --
*
* This function is the core for the translation of -exact requests.
* It translates the request of the version into a range of versions.
* The translation was chosen for backwards compatibility.
*
* Results:
* A Tcl_Obj containing the version range as string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj*
ExactRequirement(version)
CONST char* version;
{
/* A -exact request for a version X.y is translated into the range
* X.y-X.(y+1). For example -exact 8.4 means the range "8.4-8.5".
*
* This translation was chosen to prevent packages which currently use a
* 'package require -exact tclversion' from being affected by the core now
* registering itself as 8.4.x (patchlevel) instead of 8.4
* (version). Examples are tbcload, compiler, and ITcl.
*
* Translating -exact 8.4 to the range "8.4-8.4" instead would require us
* and everyone else to rebuild these packages to require -exact 8.4.14,
* or whatever the exact current patchlevel is. A backward compatibility
* issue with effects similar to the bugfix made in 8.5 now requiring
* ifneeded and provided versions to match. Instead we have chosen to
* interpret exactness to not be exactly equal, but to be exact only
* within the specified level, and allowing variation in the deeper
* level. More examples:
*
* -exact 8 => "8-9"
* -exact 8.4 => "8.4-8.5"
* -exact 8.4.14 => "8.4.14-8.4.15"
* -exact 8.0a2 => "8.0a2-8.0a3"
*/
char* iv;
int lc, i;
CONST char** lv;
char buf [30];
Tcl_Obj* o = Tcl_NewStringObj (version,-1);
Tcl_AppendStringsToObj (o, "-", NULL);
/* Assuming valid syntax here */
CheckVersionAndConvert (NULL, version, &iv, NULL);
/* Split the list into components */
Tcl_SplitList (NULL, iv, &lc, &lv);
/* Iterate over the components and make them parts of the result. Except
* for the last, which is handled separately, to allow the
* incrementation.
*/
for (i=0; i < (lc-1); i++) {
/* Regular component */
Tcl_AppendStringsToObj (o, lv[i], NULL);
/* Separator component */
i ++;
if (0 == strcmp ("-1", lv[i])) {
Tcl_AppendStringsToObj (o, "b", NULL);
} else if (0 == strcmp ("-2", lv[i])) {
Tcl_AppendStringsToObj (o, "a", NULL);
} else {
Tcl_AppendStringsToObj (o, ".", NULL);
}
}
/* Regular component, last */
sprintf (buf, "%d", atoi (lv [lc-1]) + 1);
Tcl_AppendStringsToObj (o, buf, NULL);
ckfree ((char*) lv);
return o;
}
/*
*----------------------------------------------------------------------
*
* VersionCleanupProc --
*
* This function is called to delete the last remember package version
* string for an interpreter when the interpreter is deleted. It gets
* invoked via the Tcl AssocData mechanism.
*
* Results:
* None.
*
* Side effects:
* Storage for the version object for interp get deleted.
*
*----------------------------------------------------------------------
*/
static void
VersionCleanupProc (
ClientData clientData, /* Pointer to remembered version string object
* for interp. */
Tcl_Interp *interp) /* Interpreter that is being deleted. */
{
Tcl_Obj* ov = (Tcl_Obj*) clientData;
if (ov != NULL) {
Tcl_DecrRefCount (ov);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
#endif
|
Changes to generic/tclPlatDecls.h.
1 2 3 4 5 6 7 8 | /* * tclPlatDecls.h -- * * Declarations of platform specific Tcl APIs. * * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | /* * tclPlatDecls.h -- * * Declarations of platform specific Tcl APIs. * * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * * RCS: @(#) $Id: tclPlatDecls.h,v 1.18.2.5 2004/06/10 17:17:45 andreas_kupries Exp $ */ #ifndef _TCLPLATDECLS #define _TCLPLATDECLS /* * Pull in the typedef of TCHAR for windows. |
| ︙ | ︙ | |||
78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
/* 0 */
EXTERN int Tcl_MacOSXOpenBundleResources _ANSI_ARGS_((
Tcl_Interp * interp, CONST char * bundleName,
int hasResourceFile, int maxPathLen,
char * libraryPath));
#endif /* MAC_OSX_TCL */
typedef struct TclPlatStubs {
int magic;
struct TclPlatStubHooks *hooks;
#ifdef __WIN32__
| > > > > > > | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
/* 0 */
EXTERN int Tcl_MacOSXOpenBundleResources _ANSI_ARGS_((
Tcl_Interp * interp, CONST char * bundleName,
int hasResourceFile, int maxPathLen,
char * libraryPath));
/* 1 */
EXTERN int Tcl_MacOSXOpenVersionedBundleResources _ANSI_ARGS_((
Tcl_Interp * interp, CONST char * bundleName,
CONST char * bundleVersion,
int hasResourceFile, int maxPathLen,
char * libraryPath));
#endif /* MAC_OSX_TCL */
typedef struct TclPlatStubs {
int magic;
struct TclPlatStubHooks *hooks;
#ifdef __WIN32__
|
| ︙ | ︙ | |||
101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
void (*tcl_SetOSTypeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, OSType osType)); /* 5 */
Tcl_Obj * (*tcl_NewOSTypeObj) _ANSI_ARGS_((OSType osType)); /* 6 */
int (*strncasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, size_t n)); /* 7 */
int (*strcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2)); /* 8 */
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * bundleName, int hasResourceFile, int maxPathLen, char * libraryPath)); /* 0 */
#endif /* MAC_OSX_TCL */
} TclPlatStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclPlatStubs *tclPlatStubsPtr;
| > | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
void (*tcl_SetOSTypeObj) _ANSI_ARGS_((Tcl_Obj * objPtr, OSType osType)); /* 5 */
Tcl_Obj * (*tcl_NewOSTypeObj) _ANSI_ARGS_((OSType osType)); /* 6 */
int (*strncasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, size_t n)); /* 7 */
int (*strcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2)); /* 8 */
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
int (*tcl_MacOSXOpenBundleResources) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * bundleName, int hasResourceFile, int maxPathLen, char * libraryPath)); /* 0 */
int (*tcl_MacOSXOpenVersionedBundleResources) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * bundleName, CONST char * bundleVersion, int hasResourceFile, int maxPathLen, char * libraryPath)); /* 1 */
#endif /* MAC_OSX_TCL */
} TclPlatStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclPlatStubs *tclPlatStubsPtr;
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 | #endif #endif /* MAC_TCL */ #ifdef MAC_OSX_TCL #ifndef Tcl_MacOSXOpenBundleResources #define Tcl_MacOSXOpenBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ #endif #endif /* MAC_OSX_TCL */ #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLPLATDECLS */ | > > > > | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | #endif #endif /* MAC_TCL */ #ifdef MAC_OSX_TCL #ifndef Tcl_MacOSXOpenBundleResources #define Tcl_MacOSXOpenBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenBundleResources) /* 0 */ #endif #ifndef Tcl_MacOSXOpenVersionedBundleResources #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ #endif #endif /* MAC_OSX_TCL */ #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLPLATDECLS */ |
Changes to generic/tclPort.h.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclPort.h -- * * This header file handles porting issues that occur because * of differences between systems. It reads in platform specific * portability files. * * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | | | > > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | /* * tclPort.h -- * * This header file handles porting issues that occur because * of differences between systems. It reads in platform specific * portability files. * * Copyright (c) 1994-1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPort.h,v 1.6.2.1 2003/04/16 23:31:46 dgp Exp $ */ #ifndef _TCLPORT #define _TCLPORT #include "tcl.h" #if defined(__WIN32__) # include "../win/tclWinPort.h" #else # if defined(MAC_TCL) # include "tclMacPort.h" # else # include "../unix/tclUnixPort.h" # endif #endif #if !defined(LLONG_MIN) # ifdef TCL_WIDE_INT_IS_LONG # define LLONG_MIN LONG_MIN # else # ifdef LLONG_BIT # define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1))) # else /* Assume we're on a system with a 64-bit 'long long' type */ # define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63)) # endif # endif /* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */ # define LLONG_MAX (~LLONG_MIN) #endif #endif /* _TCLPORT */ |
Changes to generic/tclPreserve.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclPreserve.c,v 1.3.34.2 2005/06/24 18:21:41 kennykb Exp $ */ #include "tclInt.h" /* * The following data structure is used to keep track of all the * Tcl_Preserve calls that are still in effect. It grows as needed |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
* not changed by anyone else. */
#endif
int refCount; /* Number of TclHandlePreserve() calls in
* effect on this handle. */
} HandleStruct;
| < < < < < < | | | < | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
* not changed by anyone else. */
#endif
int refCount; /* Number of TclHandlePreserve() calls in
* effect on this handle. */
} HandleStruct;
/*
*----------------------------------------------------------------------
*
* TclFinalizePreserve --
*
* Called during exit processing to clean up the reference array.
*
* Results:
* None.
*
* Side effects:
* Frees the storage of the reference array.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
void
TclFinalizePreserve()
{
Tcl_MutexLock(&preserveMutex);
if (spaceAvl != 0) {
ckfree((char *) refArray);
refArray = (Reference *) NULL;
inUse = 0;
spaceAvl = 0;
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 |
/*
* Make a reference array if it doesn't already exist, or make it
* bigger if it is full.
*/
if (inUse == spaceAvl) {
if (spaceAvl == 0) {
| < < | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
/*
* Make a reference array if it doesn't already exist, or make it
* bigger if it is full.
*/
if (inUse == spaceAvl) {
if (spaceAvl == 0) {
refArray = (Reference *) ckalloc((unsigned)
(INITIAL_SIZE*sizeof(Reference)));
spaceAvl = INITIAL_SIZE;
} else {
Reference *new;
new = (Reference *) ckalloc((unsigned)
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
freeProc = refPtr->freeProc;
mustFree = refPtr->mustFree;
inUse--;
if (i < inUse) {
refArray[i] = refArray[inUse];
}
if (mustFree) {
| | < | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
freeProc = refPtr->freeProc;
mustFree = refPtr->mustFree;
inUse--;
if (i < inUse) {
refArray[i] = refArray[inUse];
}
if (mustFree) {
if (freeProc == TCL_DYNAMIC) {
ckfree((char *) clientData);
} else {
Tcl_MutexUnlock(&preserveMutex);
(*freeProc)((char *) clientData);
return;
}
}
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
}
Tcl_MutexUnlock(&preserveMutex);
/*
* No reference for this block. Free it now.
*/
| | < | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 |
}
Tcl_MutexUnlock(&preserveMutex);
/*
* No reference for this block. Free it now.
*/
if (freeProc == TCL_DYNAMIC) {
ckfree((char *) clientData);
} else {
(*freeProc)((char *)clientData);
}
}
/*
|
| ︙ | ︙ |
Changes to generic/tclProc.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclProc.c -- * * This file contains routines that implement Tcl procedures, * including the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | /* * tclProc.c -- * * This file contains routines that implement Tcl procedures, * including the "proc" and "uplevel" commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclProc.c,v 1.44.2.6 2006/11/28 22:20:02 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Prototypes for static functions in this file */ static void ProcBodyDup _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *dupPtr)); static void ProcBodyFree _ANSI_ARGS_((Tcl_Obj *objPtr)); static int ProcBodySetFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr)); static int ProcCompileProc _ANSI_ARGS_((Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, CONST char *description, CONST char *procName, Proc **procPtrPtr)); static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp, char *procName, int nameLen, int returnCode)); static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Parse *parsePtr, struct CompileEnv *envPtr)); /* * The ProcBodyObjType type |
| ︙ | ︙ | |||
144 145 146 147 148 149 150 151 152 153 154 155 156 157 |
* later when the procedure is called to determine what namespace the
* procedure will run in. This will be different than the current
* namespace if the proc was renamed into a different namespace.
*/
procPtr->cmdPtr = (Command *) cmd;
/*
* Optimize for noop procs: if the body is not precompiled (like a TclPro
* procbody), and the argument list is just "args" and the body is empty,
* define a compileProc to compile a noop.
*
* Notes:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
* later when the procedure is called to determine what namespace the
* procedure will run in. This will be different than the current
* namespace if the proc was renamed into a different namespace.
*/
procPtr->cmdPtr = (Command *) cmd;
#ifdef TCL_TIP280
/* TIP #280 Remember the line the procedure body is starting on. In a
* Byte code context we ask the engine to provide us with the necessary
* information. This is for the initialization of the byte code compiler
* when the body is used for the first time.
*/
if (iPtr->cmdFramePtr) {
CmdFrame context = *iPtr->cmdFramePtr;
if (context.type == TCL_LOCATION_BC) {
TclGetSrcInfoForPc (&context);
/* May get path in context */
} else if (context.type == TCL_LOCATION_SOURCE) {
/* context now holds another reference */
Tcl_IncrRefCount (context.data.eval.path);
}
/* type == TCL_LOCATION_PREBC implies that 'line' is NULL here! We
* cannot assume that 'line' is valid here, we have to check. If the
* outer context is an eval (bc, prebc, eval) we do not save any
* information. Counting relative to the beginning of the proc body is
* more sensible than counting relative to the outer eval block.
*/
if ((context.type == TCL_LOCATION_SOURCE) &&
context.line &&
(context.nline >= 4) &&
(context.line [3] >= 0)) {
int new;
CmdFrame* cfPtr = (CmdFrame*) ckalloc (sizeof (CmdFrame));
cfPtr->level = -1;
cfPtr->type = context.type;
cfPtr->line = (int*) ckalloc (sizeof (int));
cfPtr->line [0] = context.line [3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
if (context.type == TCL_LOCATION_SOURCE) {
cfPtr->data.eval.path = context.data.eval.path;
/* Transfer of reference. The reference going away (release of
* the context) is replaced by the reference in the
* constructed cmdframe */
} else {
cfPtr->type = TCL_LOCATION_EVAL;
cfPtr->data.eval.path = NULL;
}
cfPtr->cmd.str.cmd = NULL;
cfPtr->cmd.str.len = 0;
Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->linePBodyPtr,
(char*) procPtr, &new),
cfPtr);
}
}
#endif
/*
* Optimize for noop procs: if the body is not precompiled (like a TclPro
* procbody), and the argument list is just "args" and the body is empty,
* define a compileProc to compile a noop.
*
* Notes:
|
| ︙ | ︙ | |||
898 899 900 901 902 903 904 |
register Tcl_Interp *interp; /* Interpreter in which procedure was
* invoked. */
int objc; /* Count of number of arguments to this
* procedure. */
Tcl_Obj *CONST objv[]; /* Argument value objects. */
{
Interp *iPtr = (Interp *) interp;
| | < | 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 |
register Tcl_Interp *interp; /* Interpreter in which procedure was
* invoked. */
int objc; /* Count of number of arguments to this
* procedure. */
Tcl_Obj *CONST objv[]; /* Argument value objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = (Proc *) clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame frame;
register CallFrame *framePtr = &frame;
register Var *varPtr;
register CompiledLocal *localPtr;
char *procName;
int nameLen, localCt, numArgs, argCt, i, result;
/*
* This procedure generates an array "compiledLocals" that holds the
* storage for local variables. It starts out with stack-allocated space
* but uses dynamically-allocated storage if needed.
*/
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 |
* If necessary, compile the procedure's body. The compiler will
* allocate frame slots for the procedure's non-argument local
* variables. Note that compiling the body might increase
* procPtr->numCompiledLocals if new local variables are found
* while compiling.
*/
| | | | 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 |
* If necessary, compile the procedure's body. The compiler will
* allocate frame slots for the procedure's non-argument local
* variables. Note that compiling the body might increase
* procPtr->numCompiledLocals if new local variables are found
* while compiling.
*/
result = ProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
"body of proc", procName, &procPtr);
if (result != TCL_OK) {
return result;
}
/*
* Create the "compiledLocals" array. Make sure it is large enough to
|
| ︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 |
} else {
goto incorrectArgs;
}
varPtr++;
localPtr = localPtr->nextPtr;
}
if (argCt > 0) {
incorrectArgs:
/*
* Build up equivalent to Tcl_WrongNumArgs message for proc
*/
Tcl_ResetResult(interp);
| > > > > | | > > > > > > > > > > > > > > > | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 |
} else {
goto incorrectArgs;
}
varPtr++;
localPtr = localPtr->nextPtr;
}
if (argCt > 0) {
Tcl_Obj *objResult;
int len, flags;
incorrectArgs:
/*
* Build up equivalent to Tcl_WrongNumArgs message for proc
*/
Tcl_ResetResult(interp);
objResult = Tcl_GetObjResult(interp);
Tcl_AppendToObj(objResult, "wrong # args: should be \"", -1);
/*
* Quote the proc name if it contains spaces (Bug 942757).
*/
len = Tcl_ScanCountedElement(procName, nameLen, &flags);
if (len != nameLen) {
char *procName1 = ckalloc((unsigned) len);
len = Tcl_ConvertCountedElement(procName, nameLen, procName1, flags);
Tcl_AppendToObj(objResult, procName1, len);
ckfree(procName1);
} else {
Tcl_AppendToObj(objResult, procName, len);
}
localPtr = procPtr->firstLocalPtr;
for (i = 1; i <= numArgs; i++) {
if (localPtr->defValuePtr != NULL) {
Tcl_AppendStringsToObj(objResult,
" ?", localPtr->name, "?", (char *) NULL);
} else {
Tcl_AppendStringsToObj(objResult,
|
| ︙ | ︙ | |||
1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 |
fprintf(stdout, "\n");
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
iPtr->returnCode = TCL_OK;
procPtr->refCount++;
result = TclCompEvalObj(interp, procPtr->bodyPtr);
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
if (result != TCL_OK) {
result = ProcessProcResultCode(interp, procName, nameLen, result);
| > > > > > > > > | 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 |
fprintf(stdout, "\n");
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
iPtr->returnCode = TCL_OK;
procPtr->refCount++;
#ifndef TCL_TIP280
result = TclCompEvalObj(interp, procPtr->bodyPtr);
#else
/* TIP #280: No need to set the invoking context here. The body has
* already been compiled, so the part of CompEvalObj using it is bypassed.
*/
result = TclCompEvalObj(interp, procPtr->bodyPtr, NULL, 0);
#endif
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
if (result != TCL_OK) {
result = ProcessProcResultCode(interp, procName, nameLen, result);
|
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 1137 1138 |
Proc *procPtr; /* Data associated with procedure. */
Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
* but could be any code fragment compiled
* in the context of this procedure.) */
Namespace *nsPtr; /* Namespace containing procedure. */
CONST char *description; /* string describing this body of code. */
CONST char *procName; /* Name of this procedure. */
{
Interp *iPtr = (Interp*)interp;
| > > > > > > > > > > > > > > > > > > > | > | 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 |
Proc *procPtr; /* Data associated with procedure. */
Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
* but could be any code fragment compiled
* in the context of this procedure.) */
Namespace *nsPtr; /* Namespace containing procedure. */
CONST char *description; /* string describing this body of code. */
CONST char *procName; /* Name of this procedure. */
{
return ProcCompileProc(interp, procPtr, bodyPtr, nsPtr,
description, procName, NULL);
}
static int
ProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description,
procName, procPtrPtr)
Tcl_Interp *interp; /* Interpreter containing procedure. */
Proc *procPtr; /* Data associated with procedure. */
Tcl_Obj *bodyPtr; /* Body of proc. (Usually procPtr->bodyPtr,
* but could be any code fragment compiled
* in the context of this procedure.) */
Namespace *nsPtr; /* Namespace containing procedure. */
CONST char *description; /* string describing this body of code. */
CONST char *procName; /* Name of this procedure. */
Proc **procPtrPtr; /* points to storage where a replacement
* (Proc *) value may be written, when
* appropriate */
{
Interp *iPtr = (Interp*)interp;
int i, result;
Tcl_CallFrame frame;
Proc *saveProcPtr;
ByteCode *codePtr = (ByteCode *) bodyPtr->internalRep.otherValuePtr;
CompiledLocal *localPtr;
/*
* If necessary, compile the procedure's body. The compiler will
* allocate frame slots for the procedure's non-argument local
* variables. If the ByteCode already exists, make sure it hasn't been
* invalidated by someone redefining a core command (this might make the
* compiled code wrong). Also, if the code was compiled in/for a
|
| ︙ | ︙ | |||
1201 1202 1203 1204 1205 1206 1207 | * know which proc it's compiling so that it can access its * list of compiled locals. * * TRICKY NOTE: Be careful to push a call frame with the * proper namespace context, so that the byte codes are * compiled in the appropriate class context. */ | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 |
* know which proc it's compiling so that it can access its
* list of compiled locals.
*
* TRICKY NOTE: Be careful to push a call frame with the
* proper namespace context, so that the byte codes are
* compiled in the appropriate class context.
*/
saveProcPtr = iPtr->compiledProcPtr;
if (procPtrPtr != NULL && procPtr->refCount > 1) {
Tcl_Command token;
Tcl_CmdInfo info;
Proc *new = (Proc *) ckalloc(sizeof(Proc));
new->iPtr = procPtr->iPtr;
new->refCount = 1;
new->cmdPtr = procPtr->cmdPtr;
token = (Tcl_Command) new->cmdPtr;
new->bodyPtr = Tcl_DuplicateObj(bodyPtr);
bodyPtr = new->bodyPtr;
Tcl_IncrRefCount(bodyPtr);
new->numArgs = procPtr->numArgs;
new->numCompiledLocals = new->numArgs;
new->firstLocalPtr = NULL;
new->lastLocalPtr = NULL;
localPtr = procPtr->firstLocalPtr;
for (i = 0; i < new->numArgs; i++, localPtr = localPtr->nextPtr) {
CompiledLocal *copy = (CompiledLocal *) ckalloc((unsigned)
(sizeof(CompiledLocal) -sizeof(localPtr->name)
+ localPtr->nameLength + 1));
if (new->firstLocalPtr == NULL) {
new->firstLocalPtr = new->lastLocalPtr = copy;
} else {
new->lastLocalPtr->nextPtr = copy;
new->lastLocalPtr = copy;
}
copy->nextPtr = NULL;
copy->nameLength = localPtr->nameLength;
copy->frameIndex = localPtr->frameIndex;
copy->flags = localPtr->flags;
copy->defValuePtr = localPtr->defValuePtr;
if (copy->defValuePtr) {
Tcl_IncrRefCount(copy->defValuePtr);
}
copy->resolveInfo = localPtr->resolveInfo;
strcpy(copy->name, localPtr->name);
}
/* Reset the ClientData */
Tcl_GetCommandInfoFromToken(token, &info);
if (info.objClientData == (ClientData) procPtr) {
info.objClientData = (ClientData) new;
}
if (info.clientData == (ClientData) procPtr) {
info.clientData = (ClientData) new;
}
if (info.deleteData == (ClientData) procPtr) {
info.deleteData = (ClientData) new;
}
Tcl_SetCommandInfoFromToken(token, &info);
procPtr->refCount--;
*procPtrPtr = procPtr = new;
}
iPtr->compiledProcPtr = procPtr;
result = Tcl_PushCallFrame(interp, &frame,
(Tcl_Namespace*)nsPtr, /* isProcCallFrame */ 0);
if (result == TCL_OK) {
#ifdef TCL_TIP280
/* TIP #280. We get the invoking context from the cmdFrame
* which was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
*/
Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
/* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
*/
iPtr->invokeWord = 0;
iPtr->invokeCmdFramePtr = (hePtr
? (CmdFrame*) Tcl_GetHashValue (hePtr)
: NULL);
#endif
result = tclByteCodeType.setFromAnyProc(interp, bodyPtr);
#ifdef TCL_TIP280
iPtr->invokeCmdFramePtr = NULL;
#endif
Tcl_PopCallFrame(interp);
}
iPtr->compiledProcPtr = saveProcPtr;
if (result != TCL_OK) {
if (result == TCL_ERROR) {
char buf[100 + TCL_INTEGER_SPACE];
numChars = strlen(procName);
ellipsis = "";
if (numChars > 50) {
numChars = 50;
ellipsis = "...";
}
while ( (procName[numChars] & 0xC0) == 0x80 ) {
/*
* Back up truncation point so that we don't truncate
* in the middle of a multi-byte character (in UTF-8)
*/
numChars--;
ellipsis = "...";
}
sprintf(buf, "\n (compiling %s \"%.*s%s\", line %d)",
description, numChars, procName, ellipsis,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, buf, -1);
}
return result;
}
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
/*
* The resolver epoch has changed, but we only need to invalidate
* the resolver cache.
*/
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
|
| ︙ | ︙ | |||
1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK)
? "invoked \"break\" outside of a loop"
: "invoked \"continue\" outside of a loop"), -1);
}
if (nameLen > 60) {
nameLen = 60;
ellipsis = "...";
}
sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName,
ellipsis, iPtr->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
return TCL_ERROR;
}
| > > > > > > > > | 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 |
Tcl_AppendToObj(Tcl_GetObjResult(interp), ((returnCode == TCL_BREAK)
? "invoked \"break\" outside of a loop"
: "invoked \"continue\" outside of a loop"), -1);
}
if (nameLen > 60) {
nameLen = 60;
ellipsis = "...";
}
while ( (procName[nameLen] & 0xC0) == 0x80 ) {
/*
* Back up truncation point so that we don't truncate in the
* middle of a multi-byte character (in UTF-8)
*/
nameLen--;
ellipsis = "...";
}
sprintf(msg, "\n (procedure \"%.*s%s\" line %d)", nameLen, procName,
ellipsis, iPtr->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 |
TclProcCleanupProc(procPtr)
register Proc *procPtr; /* Procedure to be deleted. */
{
register CompiledLocal *localPtr;
Tcl_Obj *bodyPtr = procPtr->bodyPtr;
Tcl_Obj *defPtr;
Tcl_ResolvedVarInfo *resVarInfo;
if (bodyPtr != NULL) {
Tcl_DecrRefCount(bodyPtr);
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
CompiledLocal *nextPtr = localPtr->nextPtr;
| > > > > > | 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 |
TclProcCleanupProc(procPtr)
register Proc *procPtr; /* Procedure to be deleted. */
{
register CompiledLocal *localPtr;
Tcl_Obj *bodyPtr = procPtr->bodyPtr;
Tcl_Obj *defPtr;
Tcl_ResolvedVarInfo *resVarInfo;
#ifdef TCL_TIP280
Tcl_HashEntry* hePtr = NULL;
CmdFrame* cfPtr = NULL;
Interp* iPtr = procPtr->iPtr;
#endif
if (bodyPtr != NULL) {
Tcl_DecrRefCount(bodyPtr);
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
CompiledLocal *nextPtr = localPtr->nextPtr;
|
| ︙ | ︙ | |||
1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 |
defPtr = localPtr->defValuePtr;
Tcl_DecrRefCount(defPtr);
}
ckfree((char *) localPtr);
localPtr = nextPtr;
}
ckfree((char *) procPtr);
}
/*
*----------------------------------------------------------------------
*
* TclUpdateReturnInfo --
*
| > > > > > > > > > > > > > > > > > > > > > > | 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 |
defPtr = localPtr->defValuePtr;
Tcl_DecrRefCount(defPtr);
}
ckfree((char *) localPtr);
localPtr = nextPtr;
}
ckfree((char *) procPtr);
#ifdef TCL_TIP280
/* TIP #280. Release the location data associated with this Proc
* structure, if any. The interpreter may not exist (For example for
* procbody structurues created by tbcload.
*/
if (!iPtr) return;
hePtr = Tcl_FindHashEntry (iPtr->linePBodyPtr, (char *) procPtr);
if (!hePtr) return;
cfPtr = (CmdFrame*) Tcl_GetHashValue (hePtr);
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (cfPtr->data.eval.path);
cfPtr->data.eval.path = NULL;
}
ckfree ((char*) cfPtr->line); cfPtr->line = NULL;
ckfree ((char*) cfPtr);
Tcl_DeleteHashEntry (hePtr);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclUpdateReturnInfo --
*
|
| ︙ | ︙ | |||
1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 |
int
TclUpdateReturnInfo(iPtr)
Interp *iPtr; /* Interpreter for which TCL_RETURN
* exception is being processed. */
{
int code;
char *errorCode;
code = iPtr->returnCode;
iPtr->returnCode = TCL_OK;
if (code == TCL_ERROR) {
errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
| > > > < | > > > < | > | 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 |
int
TclUpdateReturnInfo(iPtr)
Interp *iPtr; /* Interpreter for which TCL_RETURN
* exception is being processed. */
{
int code;
char *errorCode;
Tcl_Obj *objPtr;
code = iPtr->returnCode;
iPtr->returnCode = TCL_OK;
if (code == TCL_ERROR) {
errorCode = ((iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE");
objPtr = Tcl_NewStringObj(errorCode, -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorCode,
NULL, objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
iPtr->flags |= ERROR_CODE_SET;
if (iPtr->errorInfo != NULL) {
objPtr = Tcl_NewStringObj(iPtr->errorInfo, -1);
Tcl_IncrRefCount(objPtr);
Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
NULL, objPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objPtr);
iPtr->flags |= ERR_IN_PROGRESS;
}
}
return code;
}
/*
|
| ︙ | ︙ | |||
1697 1698 1699 1700 1701 1702 1703 |
TclEmitOpcode(INST_POP, envPtr);
}
}
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
return TCL_OK;
}
| | | > > > > > > | 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 |
TclEmitOpcode(INST_POP, envPtr);
}
}
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclRegexp.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclRegexp.c -- * * This file contains the public interfaces to the Tcl regular * expression mechanism. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclRegexp.c -- * * This file contains the public interfaces to the Tcl regular * expression mechanism. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclRegexp.c,v 1.14.4.2 2006/04/07 01:14:28 hobbs Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclRegexp.h" /* |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 | Tcl_Obj *objPtr)); /* * The regular expression Tcl object type. This serves as a cache * of the compiled form of the regular expression. */ | | | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
Tcl_Obj *objPtr));
/*
* The regular expression Tcl object type. This serves as a cache
* of the compiled form of the regular expression.
*/
static Tcl_ObjType tclRegexpType = {
"regexp", /* name */
FreeRegexpInternalRep, /* freeIntRepProc */
DupRegexpInternalRep, /* dupIntRepProc */
NULL, /* updateStringProc */
SetRegexpFromAny /* setFromAnyProc */
};
|
| ︙ | ︙ | |||
1020 1021 1022 1023 1024 1025 1026 1027 1028 |
for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
regexpPtr = tsdPtr->regexps[i];
if (--(regexpPtr->refCount) <= 0) {
FreeRegexp(regexpPtr);
}
ckfree(tsdPtr->patterns[i]);
}
}
| > > > > > > | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 |
for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
regexpPtr = tsdPtr->regexps[i];
if (--(regexpPtr->refCount) <= 0) {
FreeRegexp(regexpPtr);
}
ckfree(tsdPtr->patterns[i]);
tsdPtr->patterns[i] = NULL;
}
/*
* We may find ourselves reinitialized if another finalization routine
* invokes regexps.
*/
tsdPtr->initialized = 0;
}
|
Changes to generic/tclResult.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclResult.c -- * * This file contains code to manage the interpreter result. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclResult.c -- * * This file contains code to manage the interpreter result. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclResult.c,v 1.5.2.2 2004/09/30 22:45:15 dgp Exp $ */ #include "tclInt.h" /* * Function prototypes for local procedures in this file: */ |
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
{
TclDecrRefCount(statePtr->objResultPtr);
if (statePtr->result == statePtr->appendResult) {
ckfree(statePtr->appendResult);
} else if (statePtr->freeProc) {
| | < | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 |
Tcl_SavedResult *statePtr; /* State returned by Tcl_SaveResult. */
{
TclDecrRefCount(statePtr->objResultPtr);
if (statePtr->result == statePtr->appendResult) {
ckfree(statePtr->appendResult);
} else if (statePtr->freeProc) {
if (statePtr->freeProc == TCL_DYNAMIC) {
ckfree(statePtr->result);
} else {
(*statePtr->freeProc)(statePtr->result);
}
}
}
|
| ︙ | ︙ | |||
261 262 263 264 265 266 267 |
/*
* If the old result was dynamically-allocated, free it up. Do it
* here, rather than at the beginning, in case the new result value
* was part of the old result value.
*/
if (oldFreeProc != 0) {
| | < | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
/*
* If the old result was dynamically-allocated, free it up. Do it
* here, rather than at the beginning, in case the new result value
* was part of the old result value.
*/
if (oldFreeProc != 0) {
if (oldFreeProc == TCL_DYNAMIC) {
ckfree(oldResult);
} else {
(*oldFreeProc)(oldResult);
}
}
/*
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
TclDecrRefCount(oldObjResult);
/*
* Reset the string result since we just set the result object.
*/
if (iPtr->freeProc != NULL) {
| | < | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 |
TclDecrRefCount(oldObjResult);
/*
* Reset the string result since we just set the result object.
*/
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 |
ResetObjResult(iPtr);
objResultPtr = iPtr->objResultPtr;
length = strlen(iPtr->result);
TclInitStringRep(objResultPtr, iPtr->result, length);
if (iPtr->freeProc != NULL) {
| | < | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
ResetObjResult(iPtr);
objResultPtr = iPtr->objResultPtr;
length = strlen(iPtr->result);
TclInitStringRep(objResultPtr, iPtr->result, length);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
|
| ︙ | ︙ | |||
747 748 749 750 751 752 753 |
void
Tcl_FreeResult(interp)
register Tcl_Interp *interp; /* Interpreter for which to free result. */
{
register Interp *iPtr = (Interp *) interp;
if (iPtr->freeProc != NULL) {
| | < | 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 |
void
Tcl_FreeResult(interp)
register Tcl_Interp *interp; /* Interpreter for which to free result. */
{
register Interp *iPtr = (Interp *) interp;
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
Tcl_ResetResult(interp)
register Tcl_Interp *interp; /* Interpreter for which to clear result. */
{
register Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
if (iPtr->freeProc != NULL) {
| | < | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 |
Tcl_ResetResult(interp)
register Tcl_Interp *interp; /* Interpreter for which to clear result. */
{
register Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
(*iPtr->freeProc)(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
|
| ︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 |
}
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_ResetResult(targetInterp);
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
| > | | > > > | < | | | 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 |
}
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_ResetResult(targetInterp);
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
if (objPtr) {
Tcl_SetVar2Ex(targetInterp, "errorInfo", NULL, objPtr,
TCL_GLOBAL_ONLY);
((Interp *) targetInterp)->flags |= ERR_IN_PROGRESS;
}
objPtr = Tcl_GetVar2Ex(sourceInterp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
if (objPtr) {
Tcl_SetObjErrorCode(targetInterp, objPtr);
}
}
((Interp *) targetInterp)->returnCode = ((Interp *) sourceInterp)->returnCode;
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);
}
|
Changes to generic/tclScan.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclScan.c -- * * This file contains the implementation of the "scan" command. * * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclScan.c -- * * This file contains the implementation of the "scan" command. * * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclScan.c,v 1.12.2.2 2005/10/23 22:01:30 msofer Exp $ */ #include "tclInt.h" /* * For strtoll() and strtoull() declarations on some platforms... */ #include "tclPort.h" |
| ︙ | ︙ | |||
367 368 369 370 371 372 373 |
/*
* Handle any size specifier.
*/
switch (ch) {
case 'l':
case 'L':
| < < | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
/*
* Handle any size specifier.
*/
switch (ch) {
case 'l':
case 'L':
flags |= SCAN_LONGER;
case 'h':
format += Tcl_UtfToUniChar(format, &ch);
}
if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
goto badIndex;
}
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 |
/*
* Handle any size specifier.
*/
switch (ch) {
case 'l':
case 'L':
| < < | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
/*
* Handle any size specifier.
*/
switch (ch) {
case 'l':
case 'L':
flags |= SCAN_LONGER;
/*
* Fall through so we skip to the next character.
*/
case 'h':
format += Tcl_UtfToUniChar(format, &ch);
}
|
| ︙ | ︙ | |||
1036 1037 1038 1039 1040 1041 1042 |
}
} else {
#endif /* !TCL_WIDE_INT_IS_LONG */
value = (long) (*fn)(buf, NULL, base);
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
sprintf(buf, "%lu", value); /* INTL: ISO digit */
objPtr = Tcl_NewStringObj(buf, -1);
| | | | | | < | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 |
}
} else {
#endif /* !TCL_WIDE_INT_IS_LONG */
value = (long) (*fn)(buf, NULL, base);
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
sprintf(buf, "%lu", value); /* INTL: ISO digit */
objPtr = Tcl_NewStringObj(buf, -1);
} else if ((flags & SCAN_LONGER)
|| (unsigned long) value > UINT_MAX) {
objPtr = Tcl_NewLongObj(value);
} else {
objPtr = Tcl_NewIntObj(value);
}
#ifndef TCL_WIDE_INT_IS_LONG
}
#endif
Tcl_IncrRefCount(objPtr);
objs[objIndex++] = objPtr;
}
|
| ︙ | ︙ | |||
1169 1170 1171 1172 1173 1174 1175 1176 |
if (numVars) {
/*
* In this case, variables were specified (classic scan)
*/
for (i = 0; i < totalVars; i++) {
if (objs[i] != NULL) {
result++;
| > > | > | < | 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 |
if (numVars) {
/*
* In this case, variables were specified (classic scan)
*/
for (i = 0; i < totalVars; i++) {
if (objs[i] != NULL) {
Tcl_Obj *tmpPtr;
result++;
tmpPtr = Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0);
Tcl_DecrRefCount(objs[i]);
if (tmpPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't set variable \"",
Tcl_GetString(objv[i+3]), "\"", (char *) NULL);
code = TCL_ERROR;
}
}
}
} else {
/*
* Here no vars were specified, we want a list returned (inline scan)
*/
objPtr = Tcl_NewObj();
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 | * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclStringObj.c,v 1.32.2.2 2006/09/24 21:15:11 msofer Exp $ */ #include "tclInt.h" /* * Prototypes for procedures defined later in this file: */ |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 |
Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual
* size of this field depends on the
* 'uallocated' field above. */
} String;
#define STRING_UALLOC(numChars) \
(numChars * sizeof(Tcl_UniChar))
| | > | > | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
Tcl_UniChar unicode[2]; /* The array of Unicode chars. The actual
* size of this field depends on the
* 'uallocated' field above. */
} String;
#define STRING_UALLOC(numChars) \
(numChars * sizeof(Tcl_UniChar))
#define STRING_SIZE(ualloc) \
((unsigned) ((ualloc) \
? sizeof(String) - sizeof(Tcl_UniChar) + (ualloc) \
: sizeof(String)))
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.otherValuePtr)
#define SET_STRING(objPtr, stringPtr) \
(objPtr)->internalRep.otherValuePtr = (VOID *) (stringPtr)
/*
* TCL STRING GROWTH ALGORITHM
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
* We need to fetch the pointer again because we may have just
* reallocated the structure.
*/
stringPtr = GET_STRING(objPtr);
}
| | | 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 |
* We need to fetch the pointer again because we may have just
* reallocated the structure.
*/
stringPtr = GET_STRING(objPtr);
}
if (objPtr->bytes && stringPtr->numChars == objPtr->length) {
char *str = Tcl_GetString(objPtr);
/*
* All of the characters in the Utf string are 1 byte chars,
* so we don't store the unicode char. Create a new string
* object containing the specified range of chars.
*/
|
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclStubInit.c -- * * This file contains the initializers for the Tcl stub vectors. * * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclStubInit.c -- * * This file contains the initializers for the Tcl stub vectors. * * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclStubInit.c,v 1.79.2.10 2006/09/22 01:26:23 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * Remove macros that will interfere with the definitions below. |
| ︙ | ︙ | |||
31 32 33 34 35 36 37 38 39 40 41 42 43 44 | #undef Tcl_NewStringObj #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #if TCL_PRESERVE_BINARY_COMPATABILITY # undef Tcl_FindHashEntry # undef Tcl_CreateHashEntry #endif /* * WARNING: The contents of this file is automatically generated by the * tools/genStubs.tcl script. Any modifications to the function declarations * below should be made in the generic/tcl.decls script. */ | > > > > > > > > > > > > > > > > > > > > > > > | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
#undef Tcl_NewStringObj
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
#if TCL_PRESERVE_BINARY_COMPATABILITY
# undef Tcl_FindHashEntry
# undef Tcl_CreateHashEntry
#endif
/*
* Keep a record of the original Notifier procedures, created in the
* same compilation unit as the stub tables so we can later do reliable,
* portable comparisons to see whether a Tcl_SetNotifier() call swapped
* new routines into the stub table.
*/
Tcl_NotifierProcs tclOriginalNotifier = {
Tcl_SetTimer,
Tcl_WaitForEvent,
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
Tcl_CreateFileHandler,
Tcl_DeleteFileHandler,
#else
NULL,
NULL,
#endif
NULL,
NULL,
NULL,
NULL
};
/*
* WARNING: The contents of this file is automatically generated by the
* tools/genStubs.tcl script. Any modifications to the function declarations
* below should be made in the generic/tcl.decls script.
*/
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
TclSetStartupScriptPath, /* 167 */
TclGetStartupScriptPath, /* 168 */
TclpUtfNcmp2, /* 169 */
TclCheckInterpTraces, /* 170 */
TclCheckExecutionTraces, /* 171 */
TclInThreadExit, /* 172 */
TclUniCharMatch, /* 173 */
};
TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
NULL,
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
NULL, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
| > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
TclSetStartupScriptPath, /* 167 */
TclGetStartupScriptPath, /* 168 */
TclpUtfNcmp2, /* 169 */
TclCheckInterpTraces, /* 170 */
TclCheckExecutionTraces, /* 171 */
TclInThreadExit, /* 172 */
TclUniCharMatch, /* 173 */
NULL, /* 174 */
NULL, /* 175 */
NULL, /* 176 */
NULL, /* 177 */
NULL, /* 178 */
NULL, /* 179 */
NULL, /* 180 */
NULL, /* 181 */
TclpLocaltime, /* 182 */
TclpGmtime, /* 183 */
NULL, /* 184 */
NULL, /* 185 */
NULL, /* 186 */
NULL, /* 187 */
NULL, /* 188 */
NULL, /* 189 */
NULL, /* 190 */
NULL, /* 191 */
NULL, /* 192 */
NULL, /* 193 */
NULL, /* 194 */
NULL, /* 195 */
NULL, /* 196 */
NULL, /* 197 */
NULL, /* 198 */
TclMatchIsTrivial, /* 199 */
};
TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
NULL,
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
NULL, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
TclpLocaltime_unix, /* 11 */
TclpGmtime_unix, /* 12 */
TclpInetNtoa, /* 13 */
#endif /* UNIX */
#ifdef __WIN32__
TclWinConvertError, /* 0 */
TclWinConvertWSAError, /* 1 */
TclWinGetServByName, /* 2 */
TclWinGetSockOpt, /* 3 */
|
| ︙ | ︙ | |||
292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
TclpCreateTempFile, /* 22 */
TclpGetTZName, /* 23 */
TclWinNoBackslash, /* 24 */
TclWinGetPlatform, /* 25 */
TclWinSetInterfaces, /* 26 */
TclWinFlushDirtyChannels, /* 27 */
TclWinResetInterfaces, /* 28 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
TclpSysAlloc, /* 0 */
TclpSysFree, /* 1 */
TclpSysRealloc, /* 2 */
TclpExit, /* 3 */
FSpGetDefaultDir, /* 4 */
| > | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
TclpCreateTempFile, /* 22 */
TclpGetTZName, /* 23 */
TclWinNoBackslash, /* 24 */
TclWinGetPlatform, /* 25 */
TclWinSetInterfaces, /* 26 */
TclWinFlushDirtyChannels, /* 27 */
TclWinResetInterfaces, /* 28 */
TclWinCPUID, /* 29 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
TclpSysAlloc, /* 0 */
TclpSysFree, /* 1 */
TclpSysRealloc, /* 2 */
TclpExit, /* 3 */
FSpGetDefaultDir, /* 4 */
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
Tcl_SetOSTypeObj, /* 5 */
Tcl_NewOSTypeObj, /* 6 */
strncasecmp, /* 7 */
strcasecmp, /* 8 */
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
Tcl_MacOSXOpenBundleResources, /* 0 */
#endif /* MAC_OSX_TCL */
};
static TclStubHooks tclStubHooks = {
&tclPlatStubs,
&tclIntStubs,
&tclIntPlatStubs
| > | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
Tcl_SetOSTypeObj, /* 5 */
Tcl_NewOSTypeObj, /* 6 */
strncasecmp, /* 7 */
strcasecmp, /* 8 */
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
Tcl_MacOSXOpenBundleResources, /* 0 */
Tcl_MacOSXOpenVersionedBundleResources, /* 1 */
#endif /* MAC_OSX_TCL */
};
static TclStubHooks tclStubHooks = {
&tclPlatStubs,
&tclIntStubs,
&tclIntPlatStubs
|
| ︙ | ︙ | |||
898 899 900 901 902 903 904 905 906 907 |
Tcl_GetWideIntFromObj, /* 487 */
Tcl_NewWideIntObj, /* 488 */
Tcl_SetWideIntObj, /* 489 */
Tcl_AllocStatBuf, /* 490 */
Tcl_Seek, /* 491 */
Tcl_Tell, /* 492 */
Tcl_ChannelWideSeekProc, /* 493 */
};
/* !END!: Do not edit above this line. */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 |
Tcl_GetWideIntFromObj, /* 487 */
Tcl_NewWideIntObj, /* 488 */
Tcl_SetWideIntObj, /* 489 */
Tcl_AllocStatBuf, /* 490 */
Tcl_Seek, /* 491 */
Tcl_Tell, /* 492 */
Tcl_ChannelWideSeekProc, /* 493 */
NULL, /* 494 */
NULL, /* 495 */
NULL, /* 496 */
NULL, /* 497 */
NULL, /* 498 */
NULL, /* 499 */
NULL, /* 500 */
NULL, /* 501 */
NULL, /* 502 */
NULL, /* 503 */
NULL, /* 504 */
NULL, /* 505 */
NULL, /* 506 */
NULL, /* 507 */
NULL, /* 508 */
NULL, /* 509 */
NULL, /* 510 */
NULL, /* 511 */
NULL, /* 512 */
NULL, /* 513 */
NULL, /* 514 */
NULL, /* 515 */
NULL, /* 516 */
NULL, /* 517 */
NULL, /* 518 */
NULL, /* 519 */
NULL, /* 520 */
NULL, /* 521 */
NULL, /* 522 */
NULL, /* 523 */
NULL, /* 524 */
NULL, /* 525 */
NULL, /* 526 */
NULL, /* 527 */
NULL, /* 528 */
NULL, /* 529 */
NULL, /* 530 */
NULL, /* 531 */
NULL, /* 532 */
NULL, /* 533 */
NULL, /* 534 */
NULL, /* 535 */
NULL, /* 536 */
NULL, /* 537 */
NULL, /* 538 */
NULL, /* 539 */
NULL, /* 540 */
NULL, /* 541 */
NULL, /* 542 */
NULL, /* 543 */
NULL, /* 544 */
NULL, /* 545 */
NULL, /* 546 */
NULL, /* 547 */
NULL, /* 548 */
NULL, /* 549 */
NULL, /* 550 */
NULL, /* 551 */
NULL, /* 552 */
NULL, /* 553 */
Tcl_ChannelThreadActionProc, /* 554 */
NULL, /* 555 */
NULL, /* 556 */
NULL, /* 557 */
NULL, /* 558 */
NULL, /* 559 */
NULL, /* 560 */
NULL, /* 561 */
NULL, /* 562 */
NULL, /* 563 */
NULL, /* 564 */
NULL, /* 565 */
NULL, /* 566 */
NULL, /* 567 */
NULL, /* 568 */
NULL, /* 569 */
NULL, /* 570 */
NULL, /* 571 */
NULL, /* 572 */
Tcl_PkgRequireProc, /* 573 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclStubLib.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclStubLib.c -- * * Stub object that will be statically linked into extensions that wish * to access Tcl. * * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclStubLib.c -- * * Stub object that will be statically linked into extensions that wish * to access Tcl. * * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclStubLib.c,v 1.6.2.1 2005/11/20 18:23:03 jenglish Exp $ */ /* * We need to ensure that we use the stub macros so that this file contains * no references to any of the stub functions. This will make it possible * to build an extension that references Tcl_InitStubs but doesn't end up * including the rest of the stub functions. |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 | #include "tclPort.h" /* * Ensure that Tcl_InitStubs is built as an exported symbol. The other stub * functions should be built as non-exported symbols. */ | < < < | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | #include "tclPort.h" /* * Ensure that Tcl_InitStubs is built as an exported symbol. The other stub * functions should be built as non-exported symbols. */ TclStubs *tclStubsPtr = NULL; TclPlatStubs *tclPlatStubsPtr = NULL; TclIntStubs *tclIntStubsPtr = NULL; TclIntPlatStubs *tclIntPlatStubsPtr = NULL; static TclStubs * HasStubSupport _ANSI_ARGS_((Tcl_Interp *interp)); |
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
CONST char *
Tcl_InitStubs (interp, version, exact)
Tcl_Interp *interp;
CONST char *version;
int exact;
{
CONST char *actualVersion = NULL;
| | | < < > | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
CONST char *
Tcl_InitStubs (interp, version, exact)
Tcl_Interp *interp;
CONST char *version;
int exact;
{
CONST char *actualVersion = NULL;
ClientData pkgData = NULL;
/*
* We can't optimize this check by caching tclStubsPtr because
* that prevents apps from being able to load/unload Tcl dynamically
* multiple times. [Bug 615304]
*/
tclStubsPtr = HasStubSupport(interp);
if (!tclStubsPtr) {
return NULL;
}
actualVersion = Tcl_PkgRequireEx(interp, "Tcl", version, exact, &pkgData);
if (actualVersion == NULL) {
return NULL;
}
tclStubsPtr = (TclStubs*)pkgData;
if (tclStubsPtr->hooks) {
tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
} else {
tclPlatStubsPtr = NULL;
tclIntStubsPtr = NULL;
tclIntPlatStubsPtr = NULL;
}
return actualVersion;
}
|
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclTest.c,v 1.62.2.13 2006/09/22 01:26:23 andreas_kupries Exp $ */ #define TCL_TEST #include "tclInt.h" #include "tclPort.h" /* |
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); | < < | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestdcallCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestdelCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestdelassocdataCmd _ANSI_ARGS_((ClientData dummy, |
| ︙ | ︙ | |||
310 311 312 313 314 315 316 317 318 319 320 321 322 323 | static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr)); static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestsetCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestopenfilechannelprocCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); | > > | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | static int TestsaveresultCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static void TestsaveresultFree _ANSI_ARGS_((char *blockPtr)); static int TestsetassocdataCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestsetCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestseterrorcodeCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestsetobjerrorcodeCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestopenfilechannelprocCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); |
| ︙ | ︙ | |||
416 417 418 419 420 421 422 423 424 425 426 427 428 429 |
static Tcl_Channel SimpleOpenFileChannel _ANSI_ARGS_ ((
Tcl_Interp *interp, Tcl_Obj *fileName,
int mode, int permissions));
static Tcl_Obj* SimpleListVolumes _ANSI_ARGS_ ((void));
static int SimplePathInFilesystem _ANSI_ARGS_ ((
Tcl_Obj *pathPtr, ClientData *clientDataPtr));
static Tcl_Obj* SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr));
static Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
&TestReportInFilesystem, /* path in */
&TestReportDupInternalRep,
| > > > | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 |
static Tcl_Channel SimpleOpenFileChannel _ANSI_ARGS_ ((
Tcl_Interp *interp, Tcl_Obj *fileName,
int mode, int permissions));
static Tcl_Obj* SimpleListVolumes _ANSI_ARGS_ ((void));
static int SimplePathInFilesystem _ANSI_ARGS_ ((
Tcl_Obj *pathPtr, ClientData *clientDataPtr));
static Tcl_Obj* SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr));
static int TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
&TestReportInFilesystem, /* path in */
&TestReportDupInternalRep,
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 |
Tcl_Obj **objv;
int objc, index;
static CONST char *specialOptions[] = {
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL
};
if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
| > > > > > | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
Tcl_Obj **objv;
int objc, index;
static CONST char *specialOptions[] = {
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", (char *) NULL
};
#ifndef TCL_TIP268
if (Tcl_PkgProvide(interp, "Tcltest", TCL_VERSION) == TCL_ERROR) {
#else
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
#endif
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
| < < | 579 580 581 582 583 584 585 586 587 588 589 590 591 592 |
Tcl_CreateCommand(interp, "testaccessproc", TestaccessprocCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testasync", TestasyncCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 |
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
(ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, (ClientData) 0,
| > > > > > | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 |
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testseterr", TestsetCmd,
(ClientData) TCL_LEAVE_ERR_MSG, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, (ClientData) 0,
|
| ︙ | ︙ | |||
1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 |
* further check of the robustness of the trace proc calling code in
* TclExecuteByteCode.
*/
cmdTrace = Tcl_CreateTrace(interp, 50000,
(Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
Tcl_Eval(interp, argv[2]);
} else if ( strcmp(argv[1], "resulttest" ) == 0 ) {
/* Create an object-based trace, then eval a script. This is used
* to test return codes other than TCL_OK from the trace engine.
*/
static int deleteCalled;
deleteCalled = 0;
cmdTrace = Tcl_CreateObjTrace( interp, 50000,
| > > > > > > > > > > > > | 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 |
* further check of the robustness of the trace proc calling code in
* TclExecuteByteCode.
*/
cmdTrace = Tcl_CreateTrace(interp, 50000,
(Tcl_CmdTraceProc *) CmdTraceDeleteProc, (ClientData) NULL);
Tcl_Eval(interp, argv[2]);
} else if (strcmp(argv[1], "leveltest") == 0) {
Interp *iPtr = (Interp *) interp;
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4,
(Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
result = Tcl_Eval(interp, argv[2]);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
}
Tcl_DeleteTrace(interp, cmdTrace);
Tcl_DStringFree(&buffer);
} else if ( strcmp(argv[1], "resulttest" ) == 0 ) {
/* Create an object-based trace, then eval a script. This is used
* to test return codes other than TCL_OK from the trace engine.
*/
static int deleteCalled;
deleteCalled = 0;
cmdTrace = Tcl_CreateObjTrace( interp, 50000,
|
| ︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 |
static CONST char* positions[] = { /* Possible queue positions */
"head",
"tail",
"mark",
NULL
};
int posIndex; /* Index of the chosen position */
| > | | 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 |
static CONST char* positions[] = { /* Possible queue positions */
"head",
"tail",
"mark",
NULL
};
int posIndex; /* Index of the chosen position */
static CONST Tcl_QueuePosition posNum[] = {
/* Interpretation of the chosen position */
TCL_QUEUE_HEAD,
TCL_QUEUE_TAIL,
TCL_QUEUE_MARK
};
TestEvent* ev; /* Event to be queued */
if ( objc < 2 ) {
|
| ︙ | ︙ | |||
2791 2792 2793 2794 2795 2796 2797 |
resultPtr->intValue = ((i0 > i1)? i0 : i1);
} else if (args[1].type == TCL_DOUBLE) {
double d0 = i0;
double d1 = args[1].doubleValue;
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
| < < < < < | 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 |
resultPtr->intValue = ((i0 > i1)? i0 : i1);
} else if (args[1].type == TCL_DOUBLE) {
double d0 = i0;
double d1 = args[1].doubleValue;
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else if (args[1].type == TCL_WIDE_INT) {
Tcl_WideInt w0 = Tcl_LongAsWide(i0);
Tcl_WideInt w1 = args[1].wideValue;
resultPtr->type = TCL_WIDE_INT;
resultPtr->wideValue = ((w0 > w1)? w0 : w1);
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
result = TCL_ERROR;
}
} else if (args[0].type == TCL_DOUBLE) {
double d0 = args[0].doubleValue;
if (args[1].type == TCL_INT) {
double d1 = args[1].intValue;
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else if (args[1].type == TCL_DOUBLE) {
double d1 = args[1].doubleValue;
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else if (args[1].type == TCL_WIDE_INT) {
double d1 = Tcl_WideAsDouble(args[1].wideValue);
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
result = TCL_ERROR;
}
} else if (args[0].type == TCL_WIDE_INT) {
Tcl_WideInt w0 = args[0].wideValue;
if (args[1].type == TCL_INT) {
Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);
resultPtr->type = TCL_WIDE_INT;
|
| ︙ | ︙ | |||
2851 2852 2853 2854 2855 2856 2857 |
resultPtr->type = TCL_WIDE_INT;
resultPtr->wideValue = ((w0 > w1)? w0 : w1);
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
result = TCL_ERROR;
}
| < | 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 |
resultPtr->type = TCL_WIDE_INT;
resultPtr->wideValue = ((w0 > w1)? w0 : w1);
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
result = TCL_ERROR;
}
} else {
Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);
result = TCL_ERROR;
}
return result;
}
|
| ︙ | ︙ | |||
3335 3336 3337 3338 3339 3340 3341 |
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags®_EXPECT) && indices) {
char *varName;
CONST char *value;
int start, end;
| | | | > > > > > > > > > > > > > > | 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 |
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags®_EXPECT) && indices) {
char *varName;
CONST char *value;
int start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, -1, &start, &end);
sprintf(resinfo, "%d %d", start, end-1);
value = Tcl_SetVar(interp, varName, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", (char *) NULL);
return TCL_ERROR;
}
} else if (cflags & TCL_REG_CANMATCH) {
char *varName;
CONST char *value;
char resinfo[TCL_INTEGER_SPACE * 2];
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
sprintf(resinfo, "%ld", info.extendStart);
value = Tcl_SetVar(interp, varName, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", (char *) NULL);
return TCL_ERROR;
}
}
return TCL_OK;
|
| ︙ | ︙ | |||
3402 3403 3404 3405 3406 3407 3408 3409 |
} else if (ii > info.nsubs) {
newPtr = Tcl_NewObj();
} else {
newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
info.matches[ii].end - 1);
}
}
valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);
| > < | > | 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 |
} else if (ii > info.nsubs) {
newPtr = Tcl_NewObj();
} else {
newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
info.matches[ii].end - 1);
}
}
Tcl_IncrRefCount(newPtr);
valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);
Tcl_DecrRefCount(newPtr);
if (valuePtr == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
Tcl_GetString(varPtr), "\"", (char *) NULL);
return TCL_ERROR;
}
}
/*
|
| ︙ | ︙ | |||
3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 |
case 'a': {
cflags |= REG_ADVF;
break;
}
case 'b': {
cflags &= ~REG_ADVANCED;
break;
}
case 'e': {
cflags &= ~REG_ADVANCED;
cflags |= REG_EXTENDED;
break;
}
case 'q': {
| > > > > | 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 |
case 'a': {
cflags |= REG_ADVF;
break;
}
case 'b': {
cflags &= ~REG_ADVANCED;
break;
}
case 'c': {
cflags |= TCL_REG_CANMATCH;
break;
}
case 'e': {
cflags &= ~REG_ADVANCED;
cflags |= REG_EXTENDED;
break;
}
case 'q': {
|
| ︙ | ︙ | |||
3776 3777 3778 3779 3780 3781 3782 |
flags);
}
}
/*
*----------------------------------------------------------------------
*
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 |
flags);
}
}
/*
*----------------------------------------------------------------------
*
* TestseterrorcodeCmd --
*
* This procedure implements the "testseterrorcodeCmd".
* This tests up to five elements passed to the
* Tcl_SetErrorCode command.
*
* Results:
* A standard Tcl result. Always returns TCL_ERROR so that
* the error code can be tested.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestseterrorcodeCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc > 6) {
Tcl_SetResult(interp, "too many args", TCL_STATIC);
return TCL_ERROR;
}
Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4],
argv[5], NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestsetobjerrorcodeCmd --
*
* This procedure implements the "testsetobjerrorcodeCmd".
* This tests the Tcl_SetObjErrorCode function.
*
* Results:
* A standard Tcl result. Always returns TCL_ERROR so that
* the error code can be tested.
*
* Side effects:
* None.
|
| ︙ | ︙ | |||
3924 3925 3926 3927 3928 3929 3930 |
argString = Tcl_Merge(argc-1, argv+1);
panic(argString);
ckfree((char *)argString);
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 |
argString = Tcl_Merge(argc-1, argv+1);
panic(argString);
ckfree((char *)argString);
return TCL_OK;
}
static int
TestfileCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
Tcl_Obj *CONST argv[]; /* The argument objects. */
{
|
| ︙ | ︙ | |||
4010 4011 4012 4013 4014 4015 4016 |
}
if (argc - i > 2) {
return TCL_ERROR;
}
for (j = i; j < argc; j++) {
| | | 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 |
}
if (argc - i > 2) {
return TCL_ERROR;
}
for (j = i; j < argc; j++) {
if (Tcl_FSGetNormalizedPath(interp, argv[j]) == NULL) {
return TCL_ERROR;
}
}
subcmd = Tcl_GetString(argv[1]);
if (strcmp(subcmd, "mv") == 0) {
|
| ︙ | ︙ | |||
4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 |
Tcl_IncrRefCount(pathPtr);
ret = TclpObjStat(pathPtr, &realBuf);
Tcl_DecrRefCount(pathPtr);
if (ret != -1) {
# define OUT_OF_RANGE(x) \
(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
/*
* Perform the result-buffer overflow check manually.
*
* Note that ino_t/ino64_t is unsigned...
*/
| > > > > > > > > > > > | 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 |
Tcl_IncrRefCount(pathPtr);
ret = TclpObjStat(pathPtr, &realBuf);
Tcl_DecrRefCount(pathPtr);
if (ret != -1) {
# define OUT_OF_RANGE(x) \
(((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
#if defined(__GNUC__) && __GNUC__ >= 2
/*
* Workaround gcc warning of "comparison is always false due to limited range of
* data type" in this macro by checking max type size, and when necessary ANDing
* with the complement of ULONG_MAX instead of the comparison:
*/
# define OUT_OF_URANGE(x) \
((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \
(((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))
#else
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
#endif
/*
* Perform the result-buffer overflow check manually.
*
* Note that ino_t/ino64_t is unsigned...
*/
|
| ︙ | ︙ | |||
6087 6088 6089 6090 6091 6092 6093 |
return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName),
mode, permissions);
}
static int
TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
Tcl_Interp *interp; /* Interpreter to receive results. */
| | > > > > | | | | > | 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 |
return TclpOpenFileChannel(interp, TestReportGetNativePath(fileName),
mode, permissions);
}
static int
TestReportMatchInDirectory(interp, resultPtr, dirPtr, pattern, types)
Tcl_Interp *interp; /* Interpreter to receive results. */
Tcl_Obj *resultPtr; /* Object to lappend results. */
Tcl_Obj *dirPtr; /* Contains path to directory to search. */
CONST char *pattern; /* Pattern to match against. */
Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
* May be NULL. */
{
if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) {
TestReport("matchmounts",dirPtr, NULL);
return TCL_OK;
} else {
TestReport("matchindirectory",dirPtr, NULL);
return Tcl_FSMatchInDirectory(interp, resultPtr,
TestReportGetNativePath(dirPtr), pattern,
types);
}
}
static int
TestReportChdir(dirName)
Tcl_Obj *dirName;
{
TestReport("chdir",dirName,NULL);
return Tcl_FSChdir(TestReportGetNativePath(dirName));
|
| ︙ | ︙ | |||
6425 6426 6427 6428 6429 6430 6431 |
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/",-1);
Tcl_IncrRefCount(retVal);
return retVal;
}
| | > > > > > > > > > > > > > > > > > > > > | 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 |
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/",-1);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
if (objc > 1) {
int len = -1;
if (objc > 2) {
(void) Tcl_GetStringFromObj(objv[1], &len);
}
len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len);
Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
}
return TCL_OK;
}
|
Changes to generic/tclThread.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclThread.c -- * * This file implements Platform independent thread operations. * Most of the real work is done in the platform dependent files. * * Copyright (c) 1998 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
/*
* tclThread.c --
*
* This file implements Platform independent thread operations.
* Most of the real work is done in the platform dependent files.
*
* Copyright (c) 1998 by Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclThread.c,v 1.6.2.1 2004/05/06 01:02:59 davygrvy Exp $
*/
#include "tclInt.h"
/*
* There are three classes of synchronization objects:
* mutexes, thread data keys, and condition variables.
* The following are used to record the memory used for these
* objects so they can be finalized.
*
* These statics are guarded by the mutex in the caller of
* TclRememberThreadData, e.g., TclpThreadDataKeyInit
*/
typedef struct {
int num; /* Number of objects remembered */
int max; /* Max size of the array */
char **list; /* List of pointers */
} SyncObjRecord;
static SyncObjRecord keyRecord = {0, 0, NULL};
static SyncObjRecord mutexRecord = {0, 0, NULL};
static SyncObjRecord condRecord = {0, 0, NULL};
/*
* Prototypes of functions used only in this file
*/
static void RememberSyncObject _ANSI_ARGS_((char *objPtr,
SyncObjRecord *recPtr));
|
| ︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed * avoid lock contention). The basic strategy is to allocate memory in * fixed size blocks from block caches. * * The Initial Developer of the Original Code is America Online, Inc. * Portions created by AOL are Copyright (C) 1999 America Online, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | < > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | /* * tclThreadAlloc.c -- * * This is a very fast storage allocator for used with threads (designed * avoid lock contention). The basic strategy is to allocate memory in * fixed size blocks from block caches. * * The Initial Developer of the Original Code is America Online, Inc. * Portions created by AOL are Copyright (C) 1999 America Online, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclThreadAlloc.c,v 1.4.2.7 2005/12/20 22:16:34 dkf Exp $ */ #include "tclInt.h" #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG) #ifdef WIN32 #include "tclWinInt.h" #else extern Tcl_Mutex *TclpNewAllocMutex(void); extern void *TclpGetAllocCache(void); extern void TclpSetAllocCache(void *); |
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
/*
* The following structure defines a bucket of blocks with
* various accounting and statistics information.
*/
typedef struct Bucket {
Block *firstPtr;
| | | | | | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
/*
* The following structure defines a bucket of blocks with
* various accounting and statistics information.
*/
typedef struct Bucket {
Block *firstPtr;
long nfree;
long nget;
long nput;
long nwait;
long nlock;
long nrequest;
} Bucket;
/*
* The following structure defines a cache of buckets and objs.
*/
typedef struct Cache {
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
nextPtrPtr = &firstCachePtr;
while (*nextPtrPtr != cachePtr) {
nextPtrPtr = &(*nextPtrPtr)->nextPtr;
}
*nextPtrPtr = cachePtr->nextPtr;
cachePtr->nextPtr = NULL;
Tcl_MutexUnlock(listLockPtr);
| < < < < | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 |
nextPtrPtr = &firstCachePtr;
while (*nextPtrPtr != cachePtr) {
nextPtrPtr = &(*nextPtrPtr)->nextPtr;
}
*nextPtrPtr = cachePtr->nextPtr;
cachePtr->nextPtr = NULL;
Tcl_MutexUnlock(listLockPtr);
free(cachePtr);
}
/*
*----------------------------------------------------------------------
*
* TclpAlloc --
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 |
if (cachePtr == sharedPtr) {
Tcl_DStringAppendElement(dsPtr, "shared");
} else {
sprintf(buf, "thread%d", (int) cachePtr->owner);
Tcl_DStringAppendElement(dsPtr, buf);
}
for (n = 0; n < NBUCKETS; ++n) {
| | | | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 |
if (cachePtr == sharedPtr) {
Tcl_DStringAppendElement(dsPtr, "shared");
} else {
sprintf(buf, "thread%d", (int) cachePtr->owner);
Tcl_DStringAppendElement(dsPtr, buf);
}
for (n = 0; n < NBUCKETS; ++n) {
sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld",
(unsigned long) binfo[n].blocksize,
cachePtr->buckets[n].nfree,
cachePtr->buckets[n].nget,
cachePtr->buckets[n].nput,
cachePtr->buckets[n].nrequest,
cachePtr->buckets[n].nlock,
cachePtr->buckets[n].nwait);
Tcl_DStringAppendElement(dsPtr, buf);
|
| ︙ | ︙ | |||
947 948 949 950 951 952 953 954 955 |
((char *) blockPtr + binfo[bucket].blocksize);
blockPtr = blockPtr->b_next;
}
blockPtr->b_next = NULL;
}
return 1;
}
#endif /* TCL_THREADS */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 |
((char *) blockPtr + binfo[bucket].blocksize);
blockPtr = blockPtr->b_next;
}
blockPtr->b_next = NULL;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadAlloc --
*
* This procedure is used to destroy all private resources used in
* this file.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadAlloc()
{
int i;
for (i = 0; i < NBUCKETS; ++i) {
TclpFreeAllocMutex(binfo[i].lockPtr);
binfo[i].lockPtr = NULL;
}
TclpFreeAllocMutex(objLockPtr);
objLockPtr = NULL;
TclpFreeAllocMutex(listLockPtr);
listLockPtr = NULL;
TclpFreeAllocCache(NULL);
}
#else /* ! defined(TCL_THREADS) && ! defined(USE_THREAD_ALLOC) */
/*
*----------------------------------------------------------------------
*
* TclFinalizeThreadAlloc --
*
* This procedure is used to destroy all private resources used in
* this file.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadAlloc()
{
Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use.");
}
#endif /* TCL_THREADS */
|
Changes to generic/tclThreadTest.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclThreadTest.c -- * * This file implements the testthread command. Eventually this * should be tclThreadCmd.c * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * * Copyright (c) 1998 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclThreadTest.c -- * * This file implements the testthread command. Eventually this * should be tclThreadCmd.c * Some of this code is based on work done by Richard Hipp on behalf of * Conservation Through Innovation, Limited, with their permission. * * Copyright (c) 1998 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclThreadTest.c,v 1.16.2.2 2006/09/22 14:48:52 dkf Exp $ */ #include "tclInt.h" #ifdef TCL_THREADS /* * Each thread has an single instance of the following structure. There |
| ︙ | ︙ | |||
417 418 419 420 421 422 423 |
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
| | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 |
joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS;
Tcl_MutexLock(&threadMutex);
if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl,
TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
Tcl_MutexUnlock(&threadMutex);
Tcl_AppendResult(interp,"can't create a new thread",NULL);
ckfree((void*)ctrl.script);
return TCL_ERROR;
}
/*
* Wait for the thread to start because it is using something on our stack!
*/
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 | Tcl_Preserve((ClientData) interp); Tcl_ResetResult(interp); Tcl_CreateThreadExitHandler(ThreadFreeProc, (ClientData) threadEventPtr->script); code = Tcl_GlobalEval(interp, threadEventPtr->script); Tcl_DeleteThreadExitHandler(ThreadFreeProc, (ClientData) threadEventPtr->script); | < > | 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
Tcl_Preserve((ClientData) interp);
Tcl_ResetResult(interp);
Tcl_CreateThreadExitHandler(ThreadFreeProc,
(ClientData) threadEventPtr->script);
code = Tcl_GlobalEval(interp, threadEventPtr->script);
Tcl_DeleteThreadExitHandler(ThreadFreeProc,
(ClientData) threadEventPtr->script);
if (code != TCL_OK) {
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
result = Tcl_GetStringResult(interp);
}
ckfree(threadEventPtr->script);
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
resultPtr->result = ckalloc(strlen(result) + 1);
strcpy(resultPtr->result, result);
|
| ︙ | ︙ |
Changes to generic/tclTimer.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclTimer.c -- * * This file provides timer event management facilities for Tcl, * including the "after" command. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclTimer.c -- * * This file provides timer event management facilities for Tcl, * including the "after" command. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclTimer.c,v 1.6.2.4 2005/11/09 21:46:20 kennykb Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * For each timer callback that's pending there is one record of the following |
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
void
Tcl_DeleteTimerHandler(token)
Tcl_TimerToken token; /* Result previously returned by
* Tcl_DeleteTimerHandler. */
{
register TimerHandler *timerHandlerPtr, *prevPtr;
| | > > > | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
void
Tcl_DeleteTimerHandler(token)
Tcl_TimerToken token; /* Result previously returned by
* Tcl_DeleteTimerHandler. */
{
register TimerHandler *timerHandlerPtr, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
if (token == NULL) {
return;
}
for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL;
timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
timerHandlerPtr = timerHandlerPtr->nextPtr) {
if (timerHandlerPtr->token != token) {
continue;
}
if (prevPtr == NULL) {
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 | * *---------------------------------------------------------------------- */ /* ARGSUSED */ int Tcl_AfterObjCmd(clientData, interp, objc, objv) | | < < | < | < < > < < < < < < < < > | | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 |
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
int
Tcl_AfterObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Unused */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int ms;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
char *argString;
int index;
char buf[16 + TCL_INTEGER_SPACE];
static CONST char *afterSubCmds[] = {
"cancel", "idle", "info", (char *) NULL
};
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
/*
* Create the "after" information associated for this interpreter,
* if it doesn't already exist.
*/
assocPtr = Tcl_GetAssocData( interp, "tclAfter", NULL );
if (assocPtr == NULL) {
assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
(ClientData) assocPtr);
}
/*
* First lets see if the command was passed a number as the first argument.
*/
if (objv[1]->typePtr == &tclIntType) {
ms = (int) objv[1]->internalRep.longValue;
goto processInteger;
}
argString = Tcl_GetStringFromObj(objv[1], &length);
if (argString[0] == '+' || argString[0] == '-'
|| isdigit(UCHAR(argString[0]))) { /* INTL: digit */
if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
return TCL_ERROR;
}
processInteger:
if (ms < 0) {
ms = 0;
}
|
| ︙ | ︙ |
Changes to generic/tclUtf.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclUtf.c -- * * Routines for manipulating UTF-8 strings. * * Copyright (c) 1997-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclUtf.c -- * * Routines for manipulating UTF-8 strings. * * Copyright (c) 1997-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUtf.c,v 1.30.2.3 2005/09/07 14:35:56 dgp Exp $ */ #include "tclInt.h" /* * Include the static character classification tables and macros. */ |
| ︙ | ︙ | |||
165 166 167 168 169 170 171 |
* be large enough to hold the UTF-8 character
* (at most TCL_UTF_MAX bytes). */
{
if ((ch > 0) && (ch < UNICODE_SELF)) {
str[0] = (char) ch;
return 1;
}
| > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 |
* be large enough to hold the UTF-8 character
* (at most TCL_UTF_MAX bytes). */
{
if ((ch > 0) && (ch < UNICODE_SELF)) {
str[0] = (char) ch;
return 1;
}
if (ch >= 0) {
if (ch <= 0x7FF) {
str[1] = (char) ((ch | 0x80) & 0xBF);
str[0] = (char) ((ch >> 6) | 0xC0);
return 2;
}
if (ch <= 0xFFFF) {
three:
str[2] = (char) ((ch | 0x80) & 0xBF);
str[1] = (char) (((ch >> 6) | 0x80) & 0xBF);
str[0] = (char) ((ch >> 12) | 0xE0);
return 3;
}
#if TCL_UTF_MAX > 3
if (ch <= 0x1FFFFF) {
str[3] = (char) ((ch | 0x80) & 0xBF);
str[2] = (char) (((ch >> 6) | 0x80) & 0xBF);
str[1] = (char) (((ch >> 12) | 0x80) & 0xBF);
str[0] = (char) ((ch >> 18) | 0xF0);
return 4;
}
if (ch <= 0x3FFFFFF) {
str[4] = (char) ((ch | 0x80) & 0xBF);
str[3] = (char) (((ch >> 6) | 0x80) & 0xBF);
str[2] = (char) (((ch >> 12) | 0x80) & 0xBF);
str[1] = (char) (((ch >> 18) | 0x80) & 0xBF);
str[0] = (char) ((ch >> 24) | 0xF8);
return 5;
}
if (ch <= 0x7FFFFFFF) {
str[5] = (char) ((ch | 0x80) & 0xBF);
str[4] = (char) (((ch >> 6) | 0x80) & 0xBF);
str[3] = (char) (((ch >> 12) | 0x80) & 0xBF);
str[2] = (char) (((ch >> 18) | 0x80) & 0xBF);
str[1] = (char) (((ch >> 24) | 0x80) & 0xBF);
str[0] = (char) ((ch >> 30) | 0xFC);
return 6;
}
#endif
}
ch = 0xFFFD;
goto three;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
*
* Since this is a time-sensitive function, we also do the check for
* the single-byte char case specially.
*/
i = 0;
if (len < 0) {
| | < < < | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 |
*
* Since this is a time-sensitive function, we also do the check for
* the single-byte char case specially.
*/
i = 0;
if (len < 0) {
while (*str != '\0') {
str += TclUtfToUniChar(str, chPtr);
i++;
}
} else {
register int n;
while (len > 0) {
if (UCHAR(*str) < 0xC0) {
|
| ︙ | ︙ | |||
1290 1291 1292 1293 1294 1295 1296 |
int
Tcl_UniCharNcasecmp(cs, ct, n)
CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */
CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */
unsigned long n; /* Number of unichars to compare. */
{
for ( ; n != 0; n--, cs++, ct++) {
| | > | > | > | 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 |
int
Tcl_UniCharNcasecmp(cs, ct, n)
CONST Tcl_UniChar *cs; /* Unicode string to compare to ct. */
CONST Tcl_UniChar *ct; /* Unicode string cs is compared to. */
unsigned long n; /* Number of unichars to compare. */
{
for ( ; n != 0; n--, cs++, ct++) {
if (*cs != *ct) {
Tcl_UniChar lcs = Tcl_UniCharToLower(*cs);
Tcl_UniChar lct = Tcl_UniCharToLower(*ct);
if (lcs != lct) {
return (lcs - lct);
}
}
}
return 0;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to generic/tclUtil.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclUtil.c -- * * This file contains utility procedures that are used by many Tcl * commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclUtil.c -- * * This file contains utility procedures that are used by many Tcl * commands. * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUtil.c,v 1.36.2.8 2007/05/10 18:23:58 dgp Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The following variable holds the full path name of the binary |
| ︙ | ︙ | |||
432 433 434 435 436 437 438 |
/*
* Figure out how much space to allocate. There must be enough
* space for both the array of pointers and also for a copy of
* the list. To estimate the number of pointers needed, count
* the number of space characters in the list.
*/
| | > > > > > | > > > | < > > > > > | < | 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 |
/*
* Figure out how much space to allocate. There must be enough
* space for both the array of pointers and also for a copy of
* the list. To estimate the number of pointers needed, count
* the number of space characters in the list.
*/
for (size = 2, l = list; *l != 0; l++) {
if (isspace(UCHAR(*l))) { /* INTL: ISO space. */
size++;
/* Consecutive space can only count as a single list delimiter */
while (1) {
char next = *(l + 1);
if (next == '\0') {
break;
}
++l;
if (isspace(UCHAR(next))) {
continue;
}
break;
}
}
}
length = l - list;
argv = (CONST char **) ckalloc((unsigned)
((size * sizeof(char *)) + length + 1));
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
CONST char *prevList = list;
result = TclFindElement(interp, list, length, &element,
&list, &elSize, &brace);
length -= (list - prevList);
|
| ︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 |
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringInit --
*
* Initializes a dynamic string, discarding any previous contents
* of the string (Tcl_DStringFree should have been called already
* if the dynamic string was previously in use).
*
* Results:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 |
}
}
}
/*
*----------------------------------------------------------------------
*
* TclMatchIsTrivial --
*
* Test whether a particular glob pattern is a trivial pattern.
* (i.e. where matching is the same as equality testing).
*
* Results:
* A boolean indicating whether the pattern is free of all of the
* glob special chars.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclMatchIsTrivial(pattern)
CONST char *pattern;
{
CONST char *p = pattern;
while (1) {
switch (*p++) {
case '\0':
return 1;
case '*':
case '?':
case '[':
case '\\':
return 0;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringInit --
*
* Initializes a dynamic string, discarding any previous contents
* of the string (Tcl_DStringFree should have been called already
* if the dynamic string was previously in use).
*
* Results:
|
| ︙ | ︙ | |||
1740 1741 1742 1743 1744 1745 1746 |
if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
dsPtr->length = strlen(iPtr->result);
if (iPtr->freeProc != NULL) {
| | < | 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 |
if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
dsPtr->length = strlen(iPtr->result);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
dsPtr->string = iPtr->result;
dsPtr->spaceAvl = dsPtr->length+1;
} else {
dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1));
strcpy(dsPtr->string, iPtr->result);
(*iPtr->freeProc)(iPtr->result);
}
|
| ︙ | ︙ | |||
1919 1920 1921 1922 1923 1924 1925 |
int prec;
/*
* If the variable is unset, then recreate the trace.
*/
if (flags & TCL_TRACE_UNSETS) {
| | | 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 |
int prec;
/*
* If the variable is unset, then recreate the trace.
*/
if (flags & TCL_TRACE_UNSETS) {
if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) {
Tcl_TraceVar2(interp, name1, name2,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
}
return (char *) NULL;
}
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 |
int
TclNeedSpace(start, end)
CONST char *start; /* First character in string. */
CONST char *end; /* End of string (place where space will
* be added, if appropriate). */
{
| < < > > > > | > > | | | < > > > > > > > > > > > > > > > | | | > > > > | < | < > | | > > > < < < > | > > > > > | | | < < < < < | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 |
int
TclNeedSpace(start, end)
CONST char *start; /* First character in string. */
CONST char *end; /* End of string (place where space will
* be added, if appropriate). */
{
/*
* A space is needed unless either
* (a) we're at the start of the string, or
*/
if (end == start) {
return 0;
}
/*
* (b) we're at the start of a nested list-element, quoted with an
* open curly brace; we can be nested arbitrarily deep, so long
* as the first curly brace starts an element, so backtrack over
* open curly braces that are trailing characters of the string; and
*/
end = Tcl_UtfPrev(end, start);
while (*end == '{') {
if (end == start) {
return 0;
}
end = Tcl_UtfPrev(end, start);
}
/*
* (c) the trailing character of the string is already a list-element
* separator (according to TclFindElement); that is, one of these
* characters:
* \u0009 \t TAB
* \u000A \n NEWLINE
* \u000B \v VERTICAL TAB
* \u000C \f FORM FEED
* \u000D \r CARRIAGE RETURN
* \u0020 SPACE
* with the condition that the penultimate character is not a
* backslash.
*/
if (*end > 0x20) {
/*
* Performance tweak. All ASCII spaces are <= 0x20. So get
* a quick answer for most characters before comparing against
* all spaces in the switch below.
*
* NOTE: Remove this if other Unicode spaces ever get accepted
* as list-element separators.
*/
return 1;
}
switch (*end) {
case ' ':
case '\t':
case '\n':
case '\r':
case '\v':
case '\f':
if ((end == start) || (end[-1] != '\\')) {
return 0;
}
}
return 1;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2214 2215 2216 2217 2218 2219 2220 |
Tcl_Obj *objPtr; /* Points to an object containing either
* "end" or an integer. */
int endValue; /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr; /* Location filled in with an integer
* representing an index. */
{
| < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 |
Tcl_Obj *objPtr; /* Points to an object containing either
* "end" or an integer. */
int endValue; /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr; /* Location filled in with an integer
* representing an index. */
{
if (Tcl_GetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) {
return TCL_OK;
}
if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
/*
* If the object is already an offset from the end of the
* list, or can be converted to one, use it.
*/
*indexPtr = endValue + objPtr->internalRep.longValue;
} else {
/*
* Report a parse error.
*/
if (interp != NULL) {
char *bytes = Tcl_GetString(objPtr);
/*
* The result might not be empty; this resets it which
* should be both a cheap operation, and of little problem
* because this is an error-generation path anyway.
*/
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclVar.c,v 1.69.2.14 2007/05/10 18:23:58 dgp Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The strings below are used to indicate what went wrong when a * variable access is denied. */ static CONST char *noSuchVar = "no such variable"; |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
static void DeleteArray _ANSI_ARGS_((Interp *iPtr,
CONST char *arrayName, Var *varPtr, int flags));
static void DisposeTraceResult _ANSI_ARGS_((int flags,
char *result));
static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp,
CallFrame *framePtr, Tcl_Obj *otherP1Ptr,
CONST char *otherP2, CONST int otherFlags,
| | | > > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
static void DeleteArray _ANSI_ARGS_((Interp *iPtr,
CONST char *arrayName, Var *varPtr, int flags));
static void DisposeTraceResult _ANSI_ARGS_((int flags,
char *result));
static int ObjMakeUpvar _ANSI_ARGS_((Tcl_Interp *interp,
CallFrame *framePtr, Tcl_Obj *otherP1Ptr,
CONST char *otherP2, CONST int otherFlags,
CONST char *myName, int myFlags, int index));
static Var * NewVar _ANSI_ARGS_((void));
static ArraySearch * ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
CONST Var *varPtr, CONST char *varName,
Tcl_Obj *handleObj));
static void VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *part1, CONST char *part2,
CONST char *operation, CONST char *reason));
static int SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void UnsetVarStruct _ANSI_ARGS_((Var *varPtr, Var *arrayPtr,
Interp *iPtr, CONST char *part1, CONST char *part2,
int flags));
/*
* Functions defined in this file that may be exported in the future
* for use by the bytecode compiler and engine or to the public interface.
*/
Var * TclLookupSimpleVar _ANSI_ARGS_((Tcl_Interp *interp,
|
| ︙ | ︙ | |||
104 105 106 107 108 109 110 | * twoPtrValue.ptr1 = pointer to the array name Tcl_Obj, * or NULL if it is a scalar variable * twoPtrValue.ptr2 = pointer to the element name string * (owned by this Tcl_Obj), or NULL if * it is a scalar variable */ | | | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
* twoPtrValue.ptr1 = pointer to the array name Tcl_Obj,
* or NULL if it is a scalar variable
* twoPtrValue.ptr2 = pointer to the element name string
* (owned by this Tcl_Obj), or NULL if
* it is a scalar variable
*/
static Tcl_ObjType tclLocalVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL
};
static Tcl_ObjType tclNsVarNameType = {
"namespaceVarName",
FreeNsVarName, DupNsVarName, NULL, NULL
};
static Tcl_ObjType tclParsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL
};
/*
* Type of Tcl_Objs used to speed up array searches.
*
|
| ︙ | ︙ | |||
546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 |
Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr;
part1Ptr->typePtr = &tclLocalVarNameType;
procPtr->refCount++;
part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
} else if (index > -3) {
Namespace *nsPtr;
nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr);
varPtr->refCount++;
part1Ptr->typePtr = &tclNsVarNameType;
part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
} else {
/*
* At least mark part1Ptr as already parsed.
*/
part1Ptr->typePtr = &tclParsedVarNameType;
part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
| > > > > > > > > > > > > | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 |
Proc *procPtr = ((Interp *) interp)->varFramePtr->procPtr;
part1Ptr->typePtr = &tclLocalVarNameType;
procPtr->refCount++;
part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) index;
#if 0
/*
* TEMPORARYLY DISABLED tclNsVarNameType
*
* This optimisation will hopefully be turned back on soon.
* Miguel Sofer, 2004-05-22
*/
} else if (index > -3) {
/*
* A cacheable namespace or global variable.
*/
Namespace *nsPtr;
nsPtr = ((index == -1)? iPtr->globalNsPtr : varFramePtr->nsPtr);
varPtr->refCount++;
part1Ptr->typePtr = &tclNsVarNameType;
part1Ptr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
part1Ptr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
#endif
} else {
/*
* At least mark part1Ptr as already parsed.
*/
part1Ptr->typePtr = &tclParsedVarNameType;
part1Ptr->internalRep.twoPtrValue.ptr1 = NULL;
part1Ptr->internalRep.twoPtrValue.ptr2 = NULL;
|
| ︙ | ︙ | |||
591 592 593 594 595 596 597 598 599 600 601 602 603 604 |
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1, part2,
flags, msg, createPart1, createPart2, varPtr);
}
return varPtr;
}
/*
*----------------------------------------------------------------------
*
* TclLookupSimpleVar --
*
* This procedure is used by to locate a simple variable (i.e., not
* an array element) given its name.
| > > > > > > > > > > | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1, part2,
flags, msg, createPart1, createPart2, varPtr);
}
return varPtr;
}
/*
* This flag bit should not interfere with TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* or TCL_LEAVE_ERR_MSG; it signals that the variable lookup is performed for
* upvar (or similar) purposes, with slightly different rules:
* - Bug #696893 - variable is either proc-local or in the current
* namespace; never follow the second (global) resolution path
* - Bug #631741 - do not use special namespace or interp resolvers
*/
#define LOOKUP_FOR_UPVAR 0x40000
/*
*----------------------------------------------------------------------
*
* TclLookupSimpleVar --
*
* This procedure is used by to locate a simple variable (i.e., not
* an array element) given its name.
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
Var *
TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
CONST char *varName; /* This is a simple variable name that could
* representa scalar or an array. */
int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
| | > | 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
Var *
TclLookupSimpleVar(interp, varName, flags, create, errMsgPtr, indexPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
CONST char *varName; /* This is a simple variable name that could
* representa scalar or an array. */
int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* LOOKUP_FOR_UPVAR and TCL_LEAVE_ERR_MSG bits
* matter. */
CONST int create; /* If 1, create hash table entry for varname,
* if it doesn't already exist. If 0, return
* error if it doesn't exist. */
CONST char **errMsgPtr;
int *indexPtr;
{
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 671 672 673 674 675 676 677 |
ResolverScheme *resPtr;
Tcl_HashEntry *hPtr;
int new, i, result;
varPtr = NULL;
varNsPtr = NULL; /* set non-NULL if a nonlocal variable */
*indexPtr = -3;
/*
* If this namespace has a variable resolver, then give it first
* crack at the variable resolution. It may return a Tcl_Var
* value, it may signal to continue onward, or it may signal
* an error.
*/
| > > > > > > < < < < | < | > | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 |
ResolverScheme *resPtr;
Tcl_HashEntry *hPtr;
int new, i, result;
varPtr = NULL;
varNsPtr = NULL; /* set non-NULL if a nonlocal variable */
*indexPtr = -3;
if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
cxtNsPtr = iPtr->globalNsPtr;
} else {
cxtNsPtr = iPtr->varFramePtr->nsPtr;
}
/*
* If this namespace has a variable resolver, then give it first
* crack at the variable resolution. It may return a Tcl_Var
* value, it may signal to continue onward, or it may signal
* an error.
*/
if ((cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL)
&& !(flags & LOOKUP_FOR_UPVAR)) {
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->varResProc) {
result = (*cxtNsPtr->varResProc)(interp, varName,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
} else {
result = TCL_CONTINUE;
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
int lookGlobal;
lookGlobal = (flags & TCL_GLOBAL_ONLY)
|| (cxtNsPtr == iPtr->globalNsPtr)
|| ((*varName == ':') && (*(varName+1) == ':'));
if (lookGlobal) {
*indexPtr = -1;
| | > > > > | | | > | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 |
int lookGlobal;
lookGlobal = (flags & TCL_GLOBAL_ONLY)
|| (cxtNsPtr == iPtr->globalNsPtr)
|| ((*varName == ':') && (*(varName+1) == ':'));
if (lookGlobal) {
*indexPtr = -1;
flags = (flags | TCL_GLOBAL_ONLY) & ~(TCL_NAMESPACE_ONLY|LOOKUP_FOR_UPVAR);
} else {
if (flags & LOOKUP_FOR_UPVAR) {
flags = (flags | TCL_NAMESPACE_ONLY) & ~LOOKUP_FOR_UPVAR;
}
if (flags & TCL_NAMESPACE_ONLY) {
*indexPtr = -2;
}
}
/*
* Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable,
* or otherwise generate our own error!
*/
var = Tcl_FindNamespaceVar(interp, varName, (Tcl_Namespace *) cxtNsPtr,
flags & ~TCL_LEAVE_ERR_MSG);
|
| ︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 |
CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* and TCL_LEAVE_ERR_MSG bits. */
{
Var *varPtr, *arrayPtr;
| | | < < < < | | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 |
CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* and TCL_LEAVE_ERR_MSG bits. */
{
Var *varPtr, *arrayPtr;
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
varPtr = TclLookupVar(interp, part1, part2, flags, "read",
/*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}
|
| ︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 |
{
Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = Tcl_GetString(part1Ptr);
part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
| | | < < < < | | 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 |
{
Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = Tcl_GetString(part1Ptr);
part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
/*createPart1*/ 0, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}
|
| ︙ | ︙ | |||
1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 |
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
Var *varPtr, *arrayPtr;
varPtr = TclLookupVar(interp, part1, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
| > > > | 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT or TCL_LEAVE_ERR_MSG. */
{
Var *varPtr, *arrayPtr;
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
varPtr = TclLookupVar(interp, part1, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
|
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 |
{
Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = TclGetString(part1Ptr);
part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
| > > > | 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
{
Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = TclGetString(part1Ptr);
part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG
|TCL_APPEND_VALUE|TCL_LIST_ELEMENT);
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "set",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
|
| ︙ | ︙ | |||
1527 1528 1529 1530 1531 1532 1533 |
register Var *varPtr;
Var *arrayPtr;
CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
Tcl_Obj *newValuePtr; /* New value for variable. */
| | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
register Var *varPtr;
Var *arrayPtr;
CONST char *part1; /* Name of an array (if part2 is non-NULL)
* or the name of a variable. */
CONST char *part2; /* If non-NULL, gives the name of an element
* in the array part1. */
Tcl_Obj *newValuePtr; /* New value for variable. */
CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* and TCL_LEAVE_ERR_MSG bits. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *oldValuePtr;
Tcl_Obj *resultPtr = NULL;
int result;
|
| ︙ | ︙ | |||
1567 1568 1569 1570 1571 1572 1573 |
VarErrMsg(interp, part1, part2, "set", isArray);
}
return NULL;
}
/*
* Invoke any read traces that have been set for the variable if it
| | > > > > | | 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 |
VarErrMsg(interp, part1, part2, "set", isArray);
}
return NULL;
}
/*
* Invoke any read traces that have been set for the variable if it
* is requested; this is only done in the core by the INST_LAPPEND_*
* instructions.
*/
if ((flags & TCL_TRACE_READS) && ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL)))) {
if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
return NULL;
}
}
/*
* Set the variable's new value. If appending, append the new value to
* the variable, either as a list element or as a string. Also, if
* appending, then if the variable's old value is unshared we can modify
* it directly, otherwise we must create a new copy to modify: this is
* "copy on write".
*/
if (flags & TCL_LIST_ELEMENT && !(flags & TCL_APPEND_VALUE)) {
TclSetVarUndefined(varPtr);
}
oldValuePtr = varPtr->value.objPtr;
if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
if (TclIsVarUndefined(varPtr) && (oldValuePtr != NULL)) {
Tcl_DecrRefCount(oldValuePtr); /* discard old value */
varPtr->value.objPtr = NULL;
oldValuePtr = NULL;
}
if (flags & TCL_LIST_ELEMENT) { /* append list element */
if (oldValuePtr == NULL) {
|
| ︙ | ︙ | |||
1816 1817 1818 1819 1820 1821 1822 |
*/
createdNewObj = 0;
if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
| < < < < < < < < < | > | 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 |
*/
createdNewObj = 0;
if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
if (varValuePtr->typePtr == &tclWideIntType) {
Tcl_WideInt wide;
TclGetWide(wide,varValuePtr);
Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
} else if (varValuePtr->typePtr == &tclIntType) {
i = varValuePtr->internalRep.longValue;
Tcl_SetIntObj(varValuePtr, i + incrAmount);
} else {
/*
* Not an integer or wide internal-rep...
|
| ︙ | ︙ | |||
1849 1850 1851 1852 1853 1854 1855 |
if (wide <= Tcl_LongAsWide(LONG_MAX)
&& wide >= Tcl_LongAsWide(LONG_MIN)) {
Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount);
} else {
Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
}
}
| < | 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 |
if (wide <= Tcl_LongAsWide(LONG_MAX)
&& wide >= Tcl_LongAsWide(LONG_MIN)) {
Tcl_SetLongObj(varValuePtr, Tcl_WideAsLong(wide) + incrAmount);
} else {
Tcl_SetWideIntObj(varValuePtr, wide + Tcl_LongAsWide(incrAmount));
}
}
/*
* Store the variable's new value and run any write traces.
*/
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
varValuePtr, flags);
|
| ︙ | ︙ | |||
1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 |
* TCL_LEAVE_ERR_MSG. */
{
int result;
Tcl_Obj *part1Ptr;
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
TclDecrRefCount(part1Ptr);
return result;
}
| > > | 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 |
* TCL_LEAVE_ERR_MSG. */
{
int result;
Tcl_Obj *part1Ptr;
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
/* Filter to pass through only the flags this interface supports. */
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
TclDecrRefCount(part1Ptr);
return result;
}
|
| ︙ | ︙ | |||
1967 1968 1969 1970 1971 1972 1973 |
* to be looked up. */
Tcl_Obj *part1Ptr; /* Name of variable or array. */
CONST char *part2; /* Name of element within array or NULL. */
int flags; /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
| < | < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 |
* to be looked up. */
Tcl_Obj *part1Ptr; /* Name of variable or array. */
CONST char *part2; /* Name of element within array or NULL. */
int flags; /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_LEAVE_ERR_MSG. */
{
Var *varPtr;
Interp *iPtr = (Interp *) interp;
Var *arrayPtr;
int result;
char *part1;
part1 = TclGetString(part1Ptr);
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "unset",
/*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK);
/*
* Keep the variable alive until we're done with it. We used to
* increase/decrease the refCount for each operation, making it
* hard to find [Bug 735335] - caused by unsetting the variable
* whose value was the variable's name.
*/
varPtr->refCount++;
UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags);
/*
* It's an error to unset an undefined variable.
*/
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, "unset",
((arrayPtr == NULL) ? noSuchVar : noSuchElement));
}
}
/*
* Try to avoid keeping the Var struct allocated due to a tclNsVarNameType
* keeping a reference. This removes some additional exteriorisations of
* [Bug 736729], but may be a good thing independently of the bug.
*/
if (part1Ptr->typePtr == &tclNsVarNameType) {
part1Ptr->typePtr->freeIntRepProc(part1Ptr);
part1Ptr->typePtr = NULL;
}
/*
* Finally, if the variable is truly not in use then free up its Var
* structure and remove it from its hash table, if any. The ref count of
* its value object, if any, was decremented above.
*/
varPtr->refCount--;
CleanupVar(varPtr, arrayPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* UnsetVarStruct --
*
* Unset and delete a variable. This does the internal work for
* TclObjUnsetVar2 and TclDeleteNamespaceVars, which call here for each
* variable to be unset and deleted.
*
* Results:
* None.
*
* Side effects:
* If the arguments indicate a local or global variable in iPtr, it is
* unset and deleted.
*
*----------------------------------------------------------------------
*/
static void
UnsetVarStruct(varPtr, arrayPtr, iPtr, part1, part2, flags)
Var *varPtr;
Var *arrayPtr;
Interp *iPtr;
CONST char *part1;
CONST char *part2;
int flags;
{
Var dummyVar;
Var *dummyVarPtr;
ActiveVarTrace *activePtr;
if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
DeleteSearches(arrayPtr);
}
/*
* For global/upvar variables referenced in procedures, decrement
* the reference count on the variable referred to, and free
* the referenced variable if it's no longer needed.
*/
if (TclIsVarLink(varPtr)) {
Var *linkPtr = varPtr->value.linkPtr;
linkPtr->refCount--;
if ((linkPtr->refCount == 0) && TclIsVarUndefined(linkPtr)
&& (linkPtr->tracePtr == NULL)
&& (linkPtr->flags & VAR_IN_HASHTABLE)) {
if (linkPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(linkPtr->hPtr);
}
ckfree((char *) linkPtr);
}
}
/*
* The code below is tricky, because of the possibility that
* a trace procedure might try to access a variable being
* deleted. To handle this situation gracefully, do things
* in three steps:
* 1. Copy the contents of the variable to a dummy variable
|
| ︙ | ︙ | |||
2021 2022 2023 2024 2025 2026 2027 |
* will use dummyVar so it won't increment varPtr's refCount itself.
* 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
* call unset traces even if other traces are pending.
*/
if ((dummyVar.tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
| < < < < < < < < < < < < < < < | | < < < | < < < < < < < < < < < < < < < < < < < | 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 |
* will use dummyVar so it won't increment varPtr's refCount itself.
* 2. Turn off the VAR_TRACE_ACTIVE flag in dummyVar: we want to
* call unset traces even if other traces are pending.
*/
if ((dummyVar.tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
dummyVar.flags &= ~VAR_TRACE_ACTIVE;
CallVarTraces(iPtr, arrayPtr, &dummyVar, part1, part2,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_UNSETS, /* leaveErrMsg */ 0);
while (dummyVar.tracePtr != NULL) {
VarTrace *tracePtr = dummyVar.tracePtr;
dummyVar.tracePtr = tracePtr->nextPtr;
Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
}
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == varPtr) {
activePtr->nextTracePtr = NULL;
}
}
}
/*
* If the variable is an array, delete all of its elements. This must be
* done after calling the traces on the array, above (that's the way
* traces are defined). If it is a scalar, "discard" its object
* (decrement the ref count of its object, if any).
*/
dummyVarPtr = &dummyVar;
if (TclIsVarArray(dummyVarPtr) && !TclIsVarUndefined(dummyVarPtr)) {
DeleteArray(iPtr, part1, dummyVarPtr, (flags
& (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS);
}
if (TclIsVarScalar(dummyVarPtr)
&& (dummyVarPtr->value.objPtr != NULL)) {
Tcl_Obj *objPtr = dummyVarPtr->value.objPtr;
TclDecrRefCount(objPtr);
dummyVarPtr->value.objPtr = NULL;
}
/*
* If the variable was a namespace variable, decrement its reference count.
*/
if (varPtr->flags & VAR_NAMESPACE_VAR) {
varPtr->flags &= ~VAR_NAMESPACE_VAR;
varPtr->refCount--;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_TraceVar --
*
|
| ︙ | ︙ | |||
2640 2641 2642 2643 2644 2645 2646 |
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *varValuePtr, *newValuePtr;
register List *listRepPtr;
register Tcl_Obj **elemPtrs;
| | > > < > > | > > > > > < | < < < < < < < | > < | 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 |
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Obj *varValuePtr, *newValuePtr;
register List *listRepPtr;
register Tcl_Obj **elemPtrs;
int numElems, numRequired, createdNewObj, i, j;
Var *varPtr, *arrayPtr;
char *part1;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
return TCL_ERROR;
}
if (objc == 2) {
newValuePtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, 0);
if (newValuePtr == NULL) {
/*
* The variable doesn't exist yet. Just create it with an empty
* initial value.
*/
varValuePtr = Tcl_NewObj();
Tcl_IncrRefCount(varValuePtr);
newValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, varValuePtr,
TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(varValuePtr);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
} else {
int result;
result = Tcl_ListObjLength(interp, newValuePtr, &numElems);
if (result != TCL_OK) {
return result;
}
}
} else {
/*
* We have arguments to append. We used to call Tcl_SetVar2 to
* append each argument one at a time to ensure that traces were run
* for each append step. We now append the arguments all at once
* because it's faster. Note that a read trace and a write trace for
* the variable will now each only be called once. Also, if the
* variable's old value is unshared we modify it directly, otherwise
* we create a new copy to modify: this is "copy on write".
*
* Note that you have to protect the variable pointers around
* the TclPtrGetVar call to insure that they remain valid
* even if the variable was undefined and unused.
*/
varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
varPtr->refCount++;
if (arrayPtr != NULL) {
arrayPtr->refCount++;
}
part1 = TclGetString(objv[1]);
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, NULL,
TCL_LEAVE_ERR_MSG);
varPtr->refCount--;
if (arrayPtr != NULL) {
arrayPtr->refCount--;
}
createdNewObj = 0;
if (varValuePtr == NULL) {
/*
* We couldn't read the old value: either the var doesn't yet
* exist or it's an array element. If it's new, we will try to
* create it with Tcl_ObjSetVar2 below.
*/
varValuePtr = Tcl_NewObj();
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
|
| ︙ | ︙ | |||
2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 |
/*
* Now store the list object back into the variable. If there is an
* error setting the new value, decrement its ref count if it
* was new and we didn't create the variable.
*/
newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
varValuePtr, TCL_LEAVE_ERR_MSG);
if (newValuePtr == NULL) {
| > > < < < | 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 |
/*
* Now store the list object back into the variable. If there is an
* error setting the new value, decrement its ref count if it
* was new and we didn't create the variable.
*/
Tcl_IncrRefCount(varValuePtr);
newValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
varValuePtr, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(varValuePtr);
if (newValuePtr == NULL) {
return TCL_ERROR;
}
}
/*
* Set the interpreter's object result to refer to the variable's value
* object.
|
| ︙ | ︙ | |||
3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 |
part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);
if ((elemVarPtr == NULL) ||
(TclPtrSetVar(interp, elemVarPtr, varPtr, varName,
part2, elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) {
result = TCL_ERROR;
break;
}
}
return result;
}
}
/*
* The list is empty make sure we have an array, or create
| > > > > > > > > | 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 |
part2, TCL_LEAVE_ERR_MSG, "set", 1, 1, varPtr);
if ((elemVarPtr == NULL) ||
(TclPtrSetVar(interp, elemVarPtr, varPtr, varName,
part2, elemPtrs[i+1], TCL_LEAVE_ERR_MSG) == NULL)) {
result = TCL_ERROR;
break;
}
/*
* The TclPtrSetVar call might have shimmered
* arrayElemObj to another type, so re-fetch
* the pointers for safety.
*/
Tcl_ListObjGetElements(NULL, arrayElemObj,
&elemLen, &elemPtrs);
}
return result;
}
}
/*
* The list is empty make sure we have an array, or create
|
| ︙ | ︙ | |||
3454 3455 3456 3457 3458 3459 3460 |
* NULL means use global :: context. */
Tcl_Obj *otherP1Ptr;
CONST char *otherP2; /* Two-part name of variable in framePtr. */
CONST int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of "other" variable. */
CONST char *myName; /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
| | | 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 |
* NULL means use global :: context. */
Tcl_Obj *otherP1Ptr;
CONST char *otherP2; /* Two-part name of variable in framePtr. */
CONST int otherFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of "other" variable. */
CONST char *myName; /* Name of variable which will refer to
* otherP1/otherP2. Must be a scalar. */
int myFlags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of myName. */
int index; /* If the variable to be linked is an indexed
* scalar, this is its index. Otherwise, -1. */
{
Interp *iPtr = (Interp *) interp;
Var *otherPtr, *varPtr, *arrayPtr;
CallFrame *varFramePtr;
|
| ︙ | ︙ | |||
3486 3487 3488 3489 3490 3491 3492 |
}
if (otherPtr == NULL) {
return TCL_ERROR;
}
if (index >= 0) {
if (!varFramePtr->isProcCallFrame) {
| | | 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 |
}
if (otherPtr == NULL) {
return TCL_ERROR;
}
if (index >= 0) {
if (!varFramePtr->isProcCallFrame) {
panic("ObjMakeUpvar called with an index outside from a proc.\n");
}
varPtr = &(varFramePtr->compiledLocals[index]);
} else {
/*
* Check that we are not trying to create a namespace var linked to
* a local variable in a procedure. If we allowed this, the local
* variable in the shorter-lived procedure frame could go away
|
| ︙ | ︙ | |||
3509 3510 3511 3512 3513 3514 3515 | Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"", myName, "\": upvar won't create namespace variable that ", "refers to procedure variable", (char *) NULL); return TCL_ERROR; } /* | | > > > > > | | | 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 |
Tcl_AppendResult((Tcl_Interp *) iPtr, "bad variable name \"",
myName, "\": upvar won't create namespace variable that ",
"refers to procedure variable", (char *) NULL);
return TCL_ERROR;
}
/*
* Lookup and eventually create the new variable. Set the flag bit
* LOOKUP_FOR_UPVAR to indicate the special resolution rules for
* upvar purposes:
* - Bug #696893 - variable is either proc-local or in the current
* namespace; never follow the second (global) resolution path
* - Bug #631741 - do not use special namespace or interp resolvers
*/
varPtr = TclLookupSimpleVar(interp, myName, (myFlags | LOOKUP_FOR_UPVAR),
/* create */ 1, &errMsg, &index);
if (varPtr == NULL) {
VarErrMsg(interp, myName, NULL, "create", errMsg);
return TCL_ERROR;
}
}
if (varPtr == otherPtr) {
|
| ︙ | ︙ | |||
4068 4069 4070 4071 4072 4073 4074 |
Var *varPtr; /* Variable whose traces are to be
* invoked. */
CONST char *part1;
CONST char *part2; /* Variable's two-part name. */
int flags; /* Flags passed to trace procedures:
* indicates what's happening to variable,
* plus other stuff like TCL_GLOBAL_ONLY,
| | < > > | 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 |
Var *varPtr; /* Variable whose traces are to be
* invoked. */
CONST char *part1;
CONST char *part2; /* Variable's two-part name. */
int flags; /* Flags passed to trace procedures:
* indicates what's happening to variable,
* plus other stuff like TCL_GLOBAL_ONLY,
* or TCL_NAMESPACE_ONLY. */
CONST int leaveErrMsg; /* If true, and one of the traces indicates an
* error, then leave an error message and stack
* trace information in *iPTr. */
{
register VarTrace *tracePtr;
ActiveVarTrace active;
char *result;
CONST char *openParen, *p;
Tcl_DString nameCopy;
int copiedName;
int code = TCL_OK;
int disposeFlags = 0;
int saveErrFlags = iPtr->flags
& (ERR_IN_PROGRESS | ERR_ALREADY_LOGGED | ERROR_CODE_SET);
/*
* If there are already similar trace procedures active for the
* variable, don't call them again.
*/
if (varPtr->flags & VAR_TRACE_ACTIVE) {
|
| ︙ | ︙ | |||
4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 |
for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve((ClientData) tracePtr);
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
/* Ignore errors in unset traces */
DisposeTraceResult(tracePtr->flags, result);
} else {
| > > > | 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 |
for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve((ClientData) tracePtr);
if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
flags |= TCL_INTERP_DESTROYED;
}
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
/* Ignore errors in unset traces */
DisposeTraceResult(tracePtr->flags, result);
} else {
|
| ︙ | ︙ | |||
4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 |
for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve((ClientData) tracePtr);
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
/* Ignore errors in unset traces */
DisposeTraceResult(tracePtr->flags, result);
} else {
| > > > | 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 |
for (tracePtr = varPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve((ClientData) tracePtr);
if (Tcl_InterpDeleted((Tcl_Interp *)iPtr)) {
flags |= TCL_INTERP_DESTROYED;
}
result = (*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, part1, part2, flags);
if (result != NULL) {
if (flags & TCL_TRACE_UNSETS) {
/* Ignore errors in unset traces */
DisposeTraceResult(tracePtr->flags, result);
} else {
|
| ︙ | ︙ | |||
4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 |
/*
* Restore the variable's flags, remove the record of our active
* traces, and then return.
*/
done:
if (code == TCL_ERROR) {
if (leaveErrMsg) {
CONST char *type = "";
switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
case TCL_TRACE_READS: {
type = "read";
break;
| > > > | 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 |
/*
* Restore the variable's flags, remove the record of our active
* traces, and then return.
*/
done:
if (code == TCL_OK) {
iPtr->flags |= saveErrFlags;
}
if (code == TCL_ERROR) {
if (leaveErrMsg) {
CONST char *type = "";
switch (flags&(TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_ARRAY)) {
case TCL_TRACE_READS: {
type = "read";
break;
|
| ︙ | ︙ | |||
4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 |
ckfree((char *) searchPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclDeleteVars --
*
* This procedure is called to recycle all the storage space
* associated with a table of variables. For this procedure
* to work correctly, it must not be possible for any of the
* variables in the table to be accessed from Tcl commands
* (e.g. from trace procedures).
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 |
ckfree((char *) searchPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclDeleteNamespaceVars --
*
* This procedure is called to recycle all the storage space
* associated with a namespace's table of variables.
*
* Results:
* None.
*
* Side effects:
* Variables are deleted and trace procedures are invoked, if
* any are declared.
*
*----------------------------------------------------------------------
*/
void
TclDeleteNamespaceVars(nsPtr)
Namespace *nsPtr;
{
Tcl_HashTable *tablePtr = &nsPtr->varTable;
Tcl_Interp *interp = nsPtr->interp;
Interp *iPtr = (Interp *)interp;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
int flags = 0;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
/*
* Determine what flags to pass to the trace callback procedures.
*/
if (nsPtr == iPtr->globalNsPtr) {
flags = TCL_GLOBAL_ONLY;
} else if (nsPtr == currNsPtr) {
flags = TCL_NAMESPACE_ONLY;
}
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_FirstHashEntry(tablePtr, &search)) {
register Var *varPtr = (Var *) Tcl_GetHashValue(hPtr);
Tcl_Obj *objPtr = Tcl_NewObj();
varPtr->refCount++; /* Make sure we get to remove from hash */
Tcl_IncrRefCount(objPtr);
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
UnsetVarStruct(varPtr, NULL, iPtr, Tcl_GetString(objPtr), NULL, flags);
Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
varPtr->refCount--;
/* Remove the variable from the table and force it undefined
* in case an unset trace brought it back from the dead */
Tcl_DeleteHashEntry(hPtr);
varPtr->hPtr = NULL;
TclSetVarUndefined(varPtr);
TclSetVarScalar(varPtr);
while (varPtr->tracePtr != NULL) {
VarTrace *tracePtr = varPtr->tracePtr;
varPtr->tracePtr = tracePtr->nextPtr;
Tcl_EventuallyFree((ClientData) tracePtr, TCL_DYNAMIC);
}
CleanupVar(varPtr, NULL);
}
Tcl_DeleteHashTable(tablePtr);
}
/*
*----------------------------------------------------------------------
*
* TclDeleteVars --
*
* This procedure is called to recycle all the storage space
* associated with a table of variables. For this procedure
* to work correctly, it must not be possible for any of the
* variables in the table to be accessed from Tcl commands
* (e.g. from trace procedures).
|
| ︙ | ︙ | |||
4506 4507 4508 4509 4510 4511 4512 |
flags = TCL_TRACE_UNSETS;
if (tablePtr == &iPtr->globalNsPtr->varTable) {
flags |= TCL_GLOBAL_ONLY;
} else if (tablePtr == &currNsPtr->varTable) {
flags |= TCL_NAMESPACE_ONLY;
}
| < < < | 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 |
flags = TCL_TRACE_UNSETS;
if (tablePtr == &iPtr->globalNsPtr->varTable) {
flags |= TCL_GLOBAL_ONLY;
} else if (tablePtr == &currNsPtr->varTable) {
flags |= TCL_NAMESPACE_ONLY;
}
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
varPtr = (Var *) Tcl_GetHashValue(hPtr);
/*
* For global/upvar variables referenced in procedures, decrement
|
| ︙ | ︙ | |||
4743 4744 4745 4746 4747 4748 4749 |
DeleteArray(iPtr, arrayName, varPtr, flags)
Interp *iPtr; /* Interpreter containing array. */
CONST char *arrayName; /* Name of array (used for trace
* callbacks). */
Var *varPtr; /* Pointer to variable structure. */
int flags; /* Flags to pass to CallVarTraces:
* TCL_TRACE_UNSETS and sometimes
| < | 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 |
DeleteArray(iPtr, arrayName, varPtr, flags)
Interp *iPtr; /* Interpreter containing array. */
CONST char *arrayName; /* Name of array (used for trace
* callbacks). */
Var *varPtr; /* Pointer to variable structure. */
int flags; /* Flags to pass to CallVarTraces:
* TCL_TRACE_UNSETS and sometimes
* TCL_NAMESPACE_ONLY, or
* TCL_GLOBAL_ONLY. */
{
Tcl_HashSearch search;
register Tcl_HashEntry *hPtr;
register Var *elPtr;
ActiveVarTrace *activePtr;
|
| ︙ | ︙ |
Changes to library/auto.tcl.
1 2 3 4 5 | # auto.tcl -- # # utility procs formerly in init.tcl dealing with auto execution # of commands and can be auto loaded themselves. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # auto.tcl -- # # utility procs formerly in init.tcl dealing with auto execution # of commands and can be auto loaded themselves. # # RCS: @(#) $Id: auto.tcl,v 1.12.2.10 2005/07/23 03:31:41 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 |
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
tcl_findLibrary pkg_compareExtension
tclPkgUnknown tcl::MacOSXPkgUnknown
tcl::MacPkgUnknown} $p] < 0)} {
rename $p {}
}
}
| | < < | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
&& ([lsearch -exact {unknown pkg_mkIndex tclPkgSetup
tcl_findLibrary pkg_compareExtension
tclPkgUnknown tcl::MacOSXPkgUnknown
tcl::MacPkgUnknown} $p] < 0)} {
rename $p {}
}
}
unset -nocomplain auto_execs auto_index auto_oldpath
}
# tcl_findLibrary --
#
# This is a utility for extensions that searches for a library directory
# using a canonical searching algorithm. A side effect is to source
# the initialization script and set a global library variable.
|
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
upvar #0 $varName the_library
global env errorInfo
set dirs {}
set errors {}
# The C application may have hardwired a path, which we honor
| | | < | > > | > | > > > > > > > > > > > | > > > | > > > > > > > > > > > | < < < < < > > > | | | | | < < < < < < | > > > > > > > > > > > > > > > > > > > > > < | < | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
upvar #0 $varName the_library
global env errorInfo
set dirs {}
set errors {}
# The C application may have hardwired a path, which we honor
if {[info exists the_library] && $the_library ne ""} {
lappend dirs $the_library
} else {
# Do the canonical search
# 1. From an environment variable, if it exists.
# Placing this first gives the end-user ultimate control
# to work-around any bugs, or to customize.
if {[info exists env($enVarName)]} {
lappend dirs $env($enVarName)
}
# 2. In the package script directory registered within
# the configuration of the package itself.
#
# Only do this for Tcl 8.5+, when Tcl_RegsiterConfig() is available.
#if {[catch {
# ::${basename}::pkgconfig get scriptdir,runtime
#} value] == 0} {
# lappend dirs $value
#}
# 3. Relative to auto_path directories. This checks relative to the
# Tcl library as well as allowing loading of libraries added to the
# auto_path that is not relative to the core library or binary paths.
foreach d $::auto_path {
lappend dirs [file join $d $basename$version]
if {$::tcl_platform(platform) eq "unix"
&& $::tcl_platform(os) eq "Darwin"} {
# 4. On MacOSX, check the Resources/Scripts subdir too
lappend dirs [file join $d $basename$version Resources Scripts]
}
}
# 3. Various locations relative to the executable
# ../lib/foo1.0 (From bin directory in install hierarchy)
# ../../lib/foo1.0 (From bin/arch directory in install hierarchy)
# ../library (From unix directory in build hierarchy)
set parentDir [file dirname [file dirname [info nameofexecutable]]]
set grandParentDir [file dirname $parentDir]
lappend dirs [file join $parentDir lib $basename$version]
lappend dirs [file join $grandParentDir lib $basename$version]
lappend dirs [file join $parentDir library]
# Remaining locations are out of date (when relevant, they ought
# to be covered by the $::auto_path seach above).
#
# ../../library (From unix/arch directory in build hierarchy)
# ../../foo1.0.1/library
# (From unix directory in parallel build hierarchy)
# ../../../foo1.0.1/library
# (From unix/arch directory in parallel build hierarchy)
#
# For the sake of extra compatibility safety, we keep adding these
# paths during the 8.4.* release series.
if {1} {
lappend dirs [file join $grandParentDir library]
lappend dirs [file join $grandParentDir $basename$patch library]
lappend dirs [file join [file dirname $grandParentDir] \
$basename$patch library]
}
}
# uniquify $dirs in order
array set seen {}
foreach i $dirs {
# For Tcl 8.4.9, we've disabled the use of [file normalize] here.
# This means that two different path names that are the same path
# in normalized form, will both remain on the search path. There
# should be no harm in that, just a bit more file system access
# than is strictly necessary.
#
# [file normalize] has been disabled because of reports it has
# caused difficulties with the freewrap utility. To keep
# compatibility with freewrap's needs, we'll keep this disabled
# throughout the 8.4.x (x >= 9) releases. See Bug 1072136.
if {1 || [interp issafe]} {
set norm $i
} else {
set norm [file normalize $i]
}
if {[info exists seen($norm)]} { continue }
set seen($norm) ""
lappend uniqdirs $i
}
set dirs $uniqdirs
foreach i $dirs {
set the_library $i
set file [file join $i $initScript]
# source everything when in a safe interpreter because
# we have a source command, but no file exists command
if {[interp issafe] || [file exists $file]} {
if {![catch {uplevel #0 [list source $file]} msg]} {
return
} else {
append errors "$file: $msg\n$errorInfo\n"
}
}
}
unset -nocomplain the_library
set msg "Can't find a usable $initScript in the following directories: \n"
append msg " $dirs\n\n"
append msg "$errors\n\n"
append msg "This probably means that $basename wasn't installed properly.\n"
error $msg
}
|
| ︙ | ︙ | |||
174 175 176 177 178 179 180 |
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
| | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {[llength $args] == 0} {
set args *.tcl
}
auto_mkindex_parser::init
foreach file [eval [linsert $args 0 glob --]] {
if {[catch {auto_mkindex_parser::mkindex $file} msg] == 0} {
append index $msg
} else {
set code $errorCode
set info $errorInfo
cd $oldDir
error $msg $info $code
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 |
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
| | | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 |
append index "# Tcl autoload index file, version 2.0\n"
append index "# This file is generated by the \"auto_mkindex\" command\n"
append index "# and sourced to set up indexing information for one or\n"
append index "# more commands. Typically each line is a command that\n"
append index "# sets an element in the auto_index array, where the\n"
append index "# element name is the name of a command and the value is\n"
append index "# a script that loads the command.\n\n"
if {[llength $args] == 0} {
set args *.tcl
}
foreach file [eval [linsert $args 0 glob --]] {
set f ""
set error [catch {
set f [open $file]
while {[gets $f line] >= 0} {
if {[regexp {^proc[ ]+([^ ]*)} $line match procName]} {
set procName [lindex [auto_qualify $procName "::"] 0]
append index "set [list auto_index($procName)]"
|
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
# interpreter: references like "$x" will fail since code is not
# really being executed and variables do not really exist.
# To avoid this, we replace all $ with \0 (literally, the null char)
# later, when getting proc names we will have to reverse this replacement,
# in case there were any $ in the proc name. This will cause a problem
# if somebody actually tries to have a \0 in their proc name. Too bad
# for them.
| | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 |
# interpreter: references like "$x" will fail since code is not
# really being executed and variables do not really exist.
# To avoid this, we replace all $ with \0 (literally, the null char)
# later, when getting proc names we will have to reverse this replacement,
# in case there were any $ in the proc name. This will cause a problem
# if somebody actually tries to have a \0 in their proc name. Too bad
# for them.
set contents [string map "$ \u0000" $contents]
set index ""
set contextStack ""
set imports ""
$parser eval $contents
|
| ︙ | ︙ | |||
411 412 413 414 415 416 417 |
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::commandInit {name arglist body} {
variable parser
set ns [namespace qualifiers $name]
set tail [namespace tail $name]
| | | < < | | | 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
# body Implementation of command to handle indexing.
proc auto_mkindex_parser::commandInit {name arglist body} {
variable parser
set ns [namespace qualifiers $name]
set tail [namespace tail $name]
if {$ns eq ""} {
set fakeName [namespace current]::_%@fake_$tail
} else {
set fakeName [namespace current]::[string map {:: _} _%@fake_$name]
}
proc $fakeName $arglist $body
# YUK! Tcl won't let us alias fully qualified command names,
# so we can't handle names like "::itcl::class". Instead,
# we have to build procs with the fully qualified names, and
# have the procs point to the aliases.
if {[string match *::* $name]} {
set exportCmd [list _%@namespace export [namespace tail $name]]
$parser eval [list _%@namespace eval $ns $exportCmd]
# The following proc definition does not work if you
# want to tolerate space or something else diabolical
# in the procedure name, (i.e., space in $alias)
# The following does not work:
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 |
set name "${ns}::$name"
if {[string match ::* $name]} {
break
}
}
}
| | < | | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 |
set name "${ns}::$name"
if {[string match ::* $name]} {
break
}
}
}
if {[namespace qualifiers $name] eq ""} {
set name [namespace tail $name]
} elseif {![string match ::* $name]} {
set name "::$name"
}
# Earlier, mkindex replaced all $'s with \0. Now, we have to reverse
# that replacement.
return [string map "\u0000 $" $name]
}
# Register all of the procedures for the auto_mkindex parser that
# will build the "tclIndex" file.
# AUTO MKINDEX: proc name arglist body
# Adds an entry to the auto index list for the given procedure name.
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
# variable. Second, because the package index file may defer loading the
# library until we invoke a command, we need to explicitly invoke auto_load
# to force it to be loaded. This should be a noop if the package has
# already been loaded
auto_mkindex_parser::hook {
if {![catch {package require tbcload}]} {
| | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
# variable. Second, because the package index file may defer loading the
# library until we invoke a command, we need to explicitly invoke auto_load
# to force it to be loaded. This should be a noop if the package has
# already been loaded
auto_mkindex_parser::hook {
if {![catch {package require tbcload}]} {
if {[namespace which -command tbcload::bcproc] eq ""} {
auto_load tbcload::bcproc
}
load {} tbcload $auto_mkindex_parser::parser
# AUTO MKINDEX: tbcload::bcproc name arglist body
# Adds an entry to the auto index list for the given pre-compiled
# procedure name.
|
| ︙ | ︙ | |||
567 568 569 570 571 572 573 |
$parser eval [list _%@namespace eval $name] $args
set contextStack [lrange $contextStack 1 end]
}
import {
variable parser
variable imports
foreach pattern $args {
| | | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 |
$parser eval [list _%@namespace eval $name] $args
set contextStack [lrange $contextStack 1 end]
}
import {
variable parser
variable imports
foreach pattern $args {
if {$pattern ne "-force"} {
lappend imports $pattern
}
}
catch {$parser eval "_%@namespace import $args"}
}
}
}
return
|
Changes to library/dde/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8]} {return}
| > | | | | 1 2 3 4 5 6 7 |
if {![package vsatisfies [package provide Tcl] 8]} {return}
if {[string compare $::tcl_platform(platform) windows]} {return}
if {[info exists ::tcl_platform(debug)]} {
package ifneeded dde 1.2.4 [list load [file join $dir tcldde12g.dll] dde]
} else {
package ifneeded dde 1.2.4 [list load [file join $dir tcldde12.dll] dde]
}
|
Added library/encoding/gb2312-raw.enc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 | # Encoding file: gb2312, double-byte D 233F 0 81 21 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000030003001300230FB02C902C700A8300330052015FF5E2225202620182019 201C201D3014301530083009300A300B300C300D300E300F3016301730103011 00B100D700F72236222722282211220F222A222922082237221A22A522252220 23122299222B222E2261224C2248223D221D2260226E226F22642265221E2235 22342642264000B0203220332103FF0400A4FFE0FFE1203000A7211626062605 25CB25CF25CE25C725C625A125A025B325B2203B219221902191219330130000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 22 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000024882489248A248B248C248D248E248F2490249124922493249424952496 249724982499249A249B247424752476247724782479247A247B247C247D247E 247F248024812482248324842485248624872460246124622463246424652466 2467246824690000000032203221322232233224322532263227322832290000 00002160216121622163216421652166216721682169216A216B000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 23 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000FF01FF02FF03FFE5FF05FF06FF07FF08FF09FF0AFF0BFF0CFF0DFF0EFF0F FF10FF11FF12FF13FF14FF15FF16FF17FF18FF19FF1AFF1BFF1CFF1DFF1EFF1F FF20FF21FF22FF23FF24FF25FF26FF27FF28FF29FF2AFF2BFF2CFF2DFF2EFF2F FF30FF31FF32FF33FF34FF35FF36FF37FF38FF39FF3AFF3BFF3CFF3DFF3EFF3F FF40FF41FF42FF43FF44FF45FF46FF47FF48FF49FF4AFF4BFF4CFF4DFF4EFF4F FF50FF51FF52FF53FF54FF55FF56FF57FF58FF59FF5AFF5BFF5CFF5DFFE30000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 24 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000304130423043304430453046304730483049304A304B304C304D304E304F 3050305130523053305430553056305730583059305A305B305C305D305E305F 3060306130623063306430653066306730683069306A306B306C306D306E306F 3070307130723073307430753076307730783079307A307B307C307D307E307F 3080308130823083308430853086308730883089308A308B308C308D308E308F 3090309130923093000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 25 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000030A130A230A330A430A530A630A730A830A930AA30AB30AC30AD30AE30AF 30B030B130B230B330B430B530B630B730B830B930BA30BB30BC30BD30BE30BF 30C030C130C230C330C430C530C630C730C830C930CA30CB30CC30CD30CE30CF 30D030D130D230D330D430D530D630D730D830D930DA30DB30DC30DD30DE30DF 30E030E130E230E330E430E530E630E730E830E930EA30EB30EC30ED30EE30EF 30F030F130F230F330F430F530F6000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 26 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000039103920393039403950396039703980399039A039B039C039D039E039F 03A003A103A303A403A503A603A703A803A90000000000000000000000000000 000003B103B203B303B403B503B603B703B803B903BA03BB03BC03BD03BE03BF 03C003C103C303C403C503C603C703C803C90000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 27 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000004100411041204130414041504010416041704180419041A041B041C041D 041E041F0420042104220423042404250426042704280429042A042B042C042D 042E042F00000000000000000000000000000000000000000000000000000000 000004300431043204330434043504510436043704380439043A043B043C043D 043E043F0440044104420443044404450446044704480449044A044B044C044D 044E044F00000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 28 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000010100E101CE00E0011300E9011B00E8012B00ED01D000EC014D00F301D2 00F2016B00FA01D400F901D601D801DA01DC00FC00EA00000000000000000000 0000000000000000000031053106310731083109310A310B310C310D310E310F 3110311131123113311431153116311731183119311A311B311C311D311E311F 3120312131223123312431253126312731283129000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 29 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000002500250125022503250425052506250725082509250A250B 250C250D250E250F2510251125122513251425152516251725182519251A251B 251C251D251E251F2520252125222523252425252526252725282529252A252B 252C252D252E252F2530253125322533253425352536253725382539253A253B 253C253D253E253F2540254125422543254425452546254725482549254A254B 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 30 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000554A963F57C3632854CE550954C07691764C853C77EE827E788D72319698 978D6C285B894FFA630966975CB880FA684880AE660276CE51F9655671AC7FF1 888450B2596561CA6FB382AD634C625253ED54277B06516B75A45DF462D48DCB 9776628A8019575D97387F627238767D67CF767E64464F708D2562DC7A176591 73ED642C6273822C9881677F7248626E62CC4F3474E3534A529E7ECA90A65E2E 6886699C81807ED168D278C5868C9551508D8C2482DE80DE5305891252650000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 31 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000858496F94FDD582199715B9D62B162A566B48C799C8D7206676F789160B2 535153178F8880CC8D1D94A1500D72C8590760EB711988AB595482EF672C7B28 5D297EF7752D6CF58E668FF8903C9F3B6BD491197B145F7C78A784D6853D6BD5 6BD96BD65E015E8775F995ED655D5F0A5FC58F9F58C181C2907F965B97AD8FB9 7F168D2C62414FBF53D8535E8FA88FA98FAB904D68075F6A819888689CD6618B 522B762A5F6C658C6FD26EE85BBE6448517551B067C44E1979C9997C70B30000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 32 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000075C55E7673BB83E064AD62E894B56CE2535A52C3640F94C27B944F2F5E1B 82368116818A6E246CCA9A736355535C54FA886557E04E0D5E036B657C3F90E8 601664E6731C88C16750624D8D22776C8E2991C75F6983DC8521991053C28695 6B8B60ED60E8707F82CD82314ED36CA785CF64CD7CD969FD66F9834953957B56 4FA7518C6D4B5C428E6D63D253C9832C833667E578B4643D5BDF5C945DEE8BE7 62C667F48C7A640063BA8749998B8C177F2094F24EA7961098A4660C73160000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 33 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000573A5C1D5E38957F507F80A05382655E7545553150218D856284949E671D 56326F6E5DE2543570928F66626F64A463A35F7B6F8890F481E38FB05C186668 5FF16C8996488D81886C649179F057CE6A59621054484E587A0B60E96F848BDA 627F901E9A8B79E4540375F4630153196C608FDF5F1B9A70803B9F7F4F885C3A 8D647FC565A570BD514551B2866B5D075BA062BD916C75748E0C7A2061017B79 4EC77EF877854E1181ED521D51FA6A7153A88E87950496CF6EC19664695A0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 34 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000784050A877D7641089E6590463E35DDD7A7F693D4F20823955984E3275AE 7A975E625E8A95EF521B5439708A6376952457826625693F918755076DF37EAF 882262337EF075B5832878C196CC8F9E614874F78BCD6B64523A8D506B21806A 847156F153064ECE4E1B51D17C97918B7C074FC38E7F7BE17A9C64675D1450AC 810676017CB96DEC7FE067515B585BF878CB64AE641363AA632B9519642D8FBE 7B5476296253592754466B7950A362345E266B864EE38D37888B5F85902E0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 35 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006020803D62C54E39535590F863B880C665E66C2E4F4660EE6DE18BDE5F39 86CB5F536321515A83616863520063638E4850125C9B79775BFC52307A3B60BC 905376D75FB75F9776848E6C706F767B7B4977AA51F3909358244F4E6EF48FEA 654C7B1B72C46DA47FDF5AE162B55E95573084827B2C5E1D5F1F90127F1498A0 63826EC7789870B95178975B57AB75354F4375385E9760E659606DC06BBF7889 53FC96D551CB52016389540A94938C038DCC7239789F87768FED8C0D53E00000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 36 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004E0176EF53EE948998769F0E952D5B9A8BA24E224E1C51AC846361C252A8 680B4F97606B51BB6D1E515C6296659796618C46901775D890FD77636BD2728A 72EC8BFB583577798D4C675C9540809A5EA66E2159927AEF77ED953B6BB565AD 7F0E58065151961F5BF958A954288E726566987F56E4949D76FE9041638754C6 591A593A579B8EB267358DFA8235524160F0581586FE5CE89E454FC4989D8BB9 5A2560765384627C904F9102997F6069800C513F80335C1499756D314E8C0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 37 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008D3053D17F5A7B4F4F104E4F96006CD573D085E95E06756A7FFB6A0A77FE 94927E4151E170E653CD8FD483038D2972AF996D6CDB574A82B365B980AA623F 963259A84EFF8BBF7EBA653E83F2975E556198DE80A5532A8BFD542080BA5E9F 6CB88D3982AC915A54296C1B52067EB7575F711A6C7E7C89594B4EFD5FFF6124 7CAA4E305C0167AB87025CF0950B98CE75AF70FD902251AF7F1D8BBD594951E4 4F5B5426592B657780A45B75627662C28F905E456C1F7B264F0F4FD8670D0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 38 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006D6E6DAA798F88B15F17752B629A8F854FEF91DC65A7812F81515E9C8150 8D74526F89868D4B590D50854ED8961C723681798D1F5BCC8BA3964459877F1A 54905676560E8BE565396982949976D66E895E727518674667D17AFF809D8D76 611F79C665628D635188521A94A27F38809B7EB25C976E2F67607BD9768B9AD8 818F7F947CD5641E95507A3F544A54E56B4C640162089E3D80F3759952729769 845B683C86E49601969494EC4E2A54047ED968398DDF801566F45E9A7FB90000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 39 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000057C2803F68975DE5653B529F606D9F9A4F9B8EAC516C5BAB5F135DE96C5E 62F18D21517194A952FE6C9F82DF72D757A267848D2D591F8F9C83C754957B8D 4F306CBD5B6459D19F1353E486CA9AA88C3780A16545987E56FA96C7522E74DC 52505BE1630289024E5662D0602A68FA51735B9851A089C27BA199867F5060EF 704C8D2F51495E7F901B747089C4572D78455F529F9F95FA8F689B3C8BE17678 684267DC8DEA8D35523D8F8A6EDA68CD950590ED56FD679C88F98FC754C80000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 3A 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009AB85B696D776C264EA55BB39A87916361A890AF97E9542B6DB55BD251FD 558A7F557FF064BC634D65F161BE608D710A6C576C49592F676D822A58D5568E 8C6A6BEB90DD597D801753F76D695475559D837783CF683879BE548C4F555408 76D28C8996026CB36DB88D6B89109E648D3A563F9ED175D55F8872E0606854FC 4EA86A2A886160528F7054C470D886799E3F6D2A5B8F5F187EA255894FAF7334 543C539A5019540E547C4E4E5FFD745A58F6846B80E1877472D07CCA6E560000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 3B 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005F27864E552C62A44E926CAA623782B154D7534E733E6ED1753B52125316 8BDD69D05F8A60006DEE574F6B2273AF68538FD87F13636260A3552475EA8C62 71156DA35BA65E7B8352614C9EC478FA87577C27768751F060F6714C66435E4C 604D8C0E707063258F895FBD606286D456DE6BC160946167534960E066668D3F 79FD4F1A70E96C478BB38BF27ED88364660F5A5A9B426D516DF78C416D3B4F19 706B83B7621660D1970D8D27797851FB573E57FA673A75787A3D79EF7B950000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 3C 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000808C99658FF96FC08BA59E2159EC7EE97F095409678168D88F917C4D96C6 53CA602575BE6C7253735AC97EA7632451E0810A5DF184DF628051805B634F0E 796D524260B86D4E5BC45BC28BA18BB065E25FCC964559937EE77EAA560967B7 59394F735BB652A0835A988A8D3E753294BE50477A3C4EF767B69A7E5AC16B7C 76D1575A5C167B3A95F4714E517C80A9827059787F04832768C067EC78B17877 62E363617B804FED526A51CF835069DB92748DF58D3189C1952E7BAD4EF60000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 3D 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000506582305251996F6E106E856DA75EFA50F559DC5C066D466C5F7586848B 686859568BB253209171964D854969127901712680F64EA490CA6D479A845A07 56BC640594F077EB4FA5811A72E189D2997A7F347EDE527F655991758F7F8F83 53EB7A9663ED63A5768679F888579636622A52AB8282685467706377776B7AED 6D017ED389E359D0621285C982A5754C501F4ECB75A58BEB5C4A5DFE7B4B65A4 91D14ECA6D25895F7D2795264EC58C288FDB9773664B79818FD170EC6D780000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 3E 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005C3D52B283465162830E775B66769CB84EAC60CA7CBE7CB37ECF4E958B66 666F988897595883656C955C5F8475C997567ADF7ADE51C070AF7A9863EA7A76 7EA0739697ED4E4570784E5D915253A9655165E781FC8205548E5C31759A97A0 62D872D975BD5C459A7983CA5C40548077E94E3E6CAE805A62D2636E5DE85177 8DDD8E1E952F4FF153E560E770AC526763509E435A1F5026773753777EE26485 652B628963985014723589C951B38BC07EDD574783CC94A7519B541B5CFB0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 3F 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004FCA7AE36D5A90E19A8F55805496536154AF5F0063E9697751EF6168520A 582A52D8574E780D770B5EB761777CE0625B62974EA27095800362F770E49760 577782DB67EF68F578D5989779D158F354B353EF6E34514B523B5BA28BFE80AF 554357A660735751542D7A7A60505B5463A762A053E362635BC767AF54ED7A9F 82E691775E9388E4593857AE630E8DE880EF57577B774FA95FEB5BBD6B3E5321 7B5072C2684677FF773665F751B54E8F76D45CBF7AA58475594E9B4150800000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 40 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000998861276E8357646606634656F062EC62695ED39614578362C955878721 814A8FA3556683B167658D5684DD5A6A680F62E67BEE961151706F9C8C3063FD 89C861D27F0670C26EE57405699472FC5ECA90CE67176D6A635E52B372628001 4F6C59E5916A70D96D9D52D24E5096F7956D857E78CA7D2F5121579264C2808B 7C7B6CEA68F1695E51B7539868A872819ECE7BF172F879BB6F137406674E91CC 9CA4793C83898354540F68174E3D538952B1783E5386522950884F8B4FD00000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 41 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000075E27ACB7C926CA596B6529B748354E94FE9805483B28FDE95705EC9601C 6D9F5E18655B813894FE604B70BC7EC37CAE51C968817CB1826F4E248F8691CF 667E4EAE8C0564A9804A50DA759771CE5BE58FBD6F664E86648295635ED66599 521788C270C852A3730E7433679778F797164E3490BB9CDE6DCB51DB8D41541D 62CE73B283F196F69F8494C34F367F9A51CC707596755CAD988653E64EE46E9C 740969B4786B998F7559521876246D4167F3516D9F99804B54997B3C7ABF0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 42 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009686578462E29647697C5A0464027BD36F0F964B82A6536298855E907089 63B35364864F9C819E93788C97328DEF8D429E7F6F5E79845F559646622E9A74 541594DD4FA365C55C655C617F1586516C2F5F8B73876EE47EFF5CE6631B5B6A 6EE653754E7163A0756562A18F6E4F264ED16CA67EB68BBA841D87BA7F57903B 95237BA99AA188F8843D6D1B9A867EDC59889EBB739B780186829A6C9A82561B 541757CB4E709EA653568FC881097792999286EE6EE1851366FC61626F2B0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 43 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008C298292832B76F26C135FD983BD732B8305951A6BDB77DB94C6536F8302 51925E3D8C8C8D384E4873AB679A68859176970971646CA177095A9295416BCF 7F8E66275BD059B95A9A95E895F74EEC840C84996AAC76DF9530731B68A65B5F 772F919A97617CDC8FF78C1C5F257C7379D889C56CCC871C5BC65E4268C97720 7EF55195514D52C95A297F05976282D763CF778485D079D26E3A5E9959998511 706D6C1162BF76BF654F60AF95FD660E879F9E2394ED540D547D8C2C64780000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 44 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000647986116A21819C78E864699B5462B9672B83AB58A89ED86CAB6F205BDE 964C8C0B725F67D062C772614EA959C66BCD589366AE5E5552DF6155672876EE 776672677A4662FF54EA545094A090A35A1C7EB36C164E435976801059485357 753796BE56CA63208111607C95F96DD65462998151855AE980FD59AE9713502A 6CE55C3C62DF4F60533F817B90066EBA852B62C85E7478BE64B5637B5FF55A18 917F9E1F5C3F634F80425B7D556E954A954D6D8560A867E072DE51DD5B810000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 45 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000062E76CDE725B626D94AE7EBD81136D53519C5F04597452AA601259736696 8650759F632A61E67CEF8BFA54E66B279E256BB485D5545550766CA4556A8DB4 722C5E156015743662CD6392724C5F986E436D3E65006F5876D878D076FC7554 522453DB4E535E9E65C1802A80D6629B5486522870AE888D8DD16CE1547880DA 57F988F48D54966A914D4F696C9B55B776C6783062A870F96F8E5F6D84EC68DA 787C7BF781A8670B9E4F636778B0576F78129739627962AB528874356BD70000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 46 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005564813E75B276AE533975DE50FB5C418B6C7BC7504F72479A9798D86F02 74E27968648777A562FC98918D2B54C180584E52576A82F9840D5E7351ED74F6 8BC45C4F57616CFC98875A4678349B448FEB7C955256625194FA4EC683868461 83E984B257D467345703666E6D668C3166DD7011671F6B3A6816621A59BB4E03 51C46F0667D26C8F517668CB59476B6775665D0E81109F5065D7794879419A91 8D775C824E5E4F01542F5951780C56686C148FC45F036C7D6CE38BAB63900000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 47 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000060706D3D72756266948E94C553438FC17B7E4EDF8C264E7E9ED494B194B3 524D6F5C90636D458C3458115D4C6B206B4967AA545B81547F8C589985375F3A 62A26A47953965726084686577A74E544FA85DE7979864AC7FD85CED4FCF7A8D 520783044E14602F7A8394A64FB54EB279E6743452E482B964D279BD5BDD6C81 97528F7B6C22503E537F6E0564CE66746C3060C598778BF75E86743C7A7779CB 4E1890B174036C4256DA914B6CC58D8B533A86C666F28EAF5C489A716E200000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 48 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000053D65A369F8B8DA353BB570898A76743919B6CC9516875CA62F372AC5238 529D7F3A7094763853749E4A69B7786E96C088D97FA4713671C3518967D374E4 58E4651856B78BA9997662707ED560F970ED58EC4EC14EBA5FCD97E74EFB8BA4 5203598A7EAB62544ECD65E5620E833884C98363878D71946EB65BB97ED25197 63C967D480898339881551125B7A59828FB14E736C5D516589258F6F962E854A 745E951095F06DA682E55F3164926D128428816E9CC3585E8D5B4E0953C10000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 49 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004F1E6563685155D34E2764149A9A626B5AC2745F82726DA968EE50E7838E 7802674052396C997EB150BB5565715E7B5B665273CA82EB67495C715220717D 886B95EA965564C58D6181B355846C5562477F2E58924F2455468D4F664C4E0A 5C1A88F368A2634E7A0D70E7828D52FA97F65C1154E890B57ECD59628D4A86C7 820C820D8D6664445C0461516D89793E8BBE78377533547B4F388EAB6DF15A20 7EC5795E6C885BA15A76751A80BE614E6E1758F0751F7525727253477EF30000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 4A 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000770176DB526980DC57235E08593172EE65BD6E7F8BD75C388671534177F3 62FE65F64EC098DF86805B9E8BC653F277E24F7F5C4E9A7659CB5F0F793A58EB 4E1667FF4E8B62ED8A93901D52BF662F55DC566C90024ED54F8D91CA99706C0F 5E0260435BA489C68BD56536624B99965B885BFF6388552E53D77626517D852C 67A268B36B8A62928F9353D482126DD1758F4E668D4E5B70719F85AF669166D9 7F7287009ECD9F205C5E672F8FF06811675F620D7AD658855EB665706F310000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 4B 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000060555237800D6454887075295E05681362F4971C53CC723D8C016C347761 7A0E542E77AC987A821C8BF47855671470C165AF64955636601D79C153F84E1D 6B7B80865BFA55E356DB4F3A4F3C99725DF3677E80386002988290015B8B8BBC 8BF5641C825864DE55FD82CF91654FD77D20901F7C9F50F358516EAF5BBF8BC9 80839178849C7B97867D968B968F7EE59AD3788E5C817A57904296A7795F5B59 635F7B0B84D168AD55067F2974107D2295016240584C4ED65B83597958540000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 4C 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000736D631E8E4B8E0F80CE82D462AC53F06CF0915E592A60016C70574D644A 8D2A762B6EE9575B6A8075F06F6D8C2D8C0857666BEF889278B363A253F970AD 6C645858642A580268E0819B55107CD650188EBA6DCC8D9F70EB638F6D9B6ED4 7EE68404684390036DD896768BA85957727985E4817E75BC8A8A68AF52548E22 951163D098988E44557C4F5366FF568F60D56D9552435C4959296DFB586B7530 751C606C82148146631167618FE2773A8DF38D3494C15E165385542C70C30000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 4D 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006C405EF7505C4EAD5EAD633A8247901A6850916E77B3540C94DC5F647AE5 687663457B527EDF75DB507762955934900F51F879C37A8156FE5F9290146D82 5C60571F541051546E4D56E263A89893817F8715892A9000541E5C6F81C062D6 625881319E3596409A6E9A7C692D59A562D3553E631654C786D96D3C5A0374E6 889C6B6A59168C4C5F2F6E7E73A9987D4E3870F75B8C7897633D665A769660CB 5B9B5A494E0781556C6A738B4EA167897F515F8065FA671B5FD859845A010000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 4E 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005DCD5FAE537197E68FDD684556F4552F60DF4E3A6F4D7EF482C7840E59D4 4F1F4F2A5C3E7EAC672A851A5473754F80C355829B4F4F4D6E2D8C135C096170 536B761F6E29868A658795FB7EB9543B7A337D0A95EE55E17FC174EE631D8717 6DA17A9D621165A1536763E16C835DEB545C94A84E4C6C618BEC5C4B65E0829C 68A7543E54346BCB6B664E9463425348821E4F0D4FAE575E620A96FE66647269 52FF52A1609F8BEF661471996790897F785277FD6670563B54389521727A0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 4F 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00007A00606F5E0C6089819D591560DC718470EF6EAA6C5072806A8488AD5E2D 4E605AB3559C94E36D177CFB9699620F7EC6778E867E5323971E8F9666875CE1 4FA072ED4E0B53A6590F54136380952851484ED99C9C7EA454B88D2488548237 95F26D8E5F265ACC663E966973B0732E53BF817A99857FA15BAA967796507EBF 76F853A2957699997BB189446E584E617FD479658BE660F354CD4EAB98795DF7 6A6150CF54118C618427785D9704524A54EE56A395006D885BB56DC666530000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 50 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005C0F5B5D6821809655787B11654869544E9B6B47874E978B534F631F643A 90AA659C80C18C10519968B0537887F961C86CC46CFB8C225C5185AA82AF950C 6B238F9B65B05FFB5FC34FE18845661F8165732960FA51745211578B5F6290A2 884C91925E78674F602759D3514451F680F853086C7996C4718A4F114FEE7F9E 673D55C5950879C088967EE3589F620C9700865A5618987B5F908BB884C49157 53D965ED5E8F755C60647D6E5A7F7EEA7EED8F6955A75BA360AC65CB73840000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 51 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009009766377297EDA9774859B5B667A7496EA884052CB718F5FAA65EC8BE2 5BFB9A6F5DE16B896C5B8BAD8BAF900A8FC5538B62BC9E269E2D54404E2B82BD 7259869C5D1688596DAF96C554D14E9A8BB6710954BD960970DF6DF976D04E25 781487125CA95EF68A00989C960E708E6CBF594463A9773C884D6F1482735830 71D5538C781A96C155015F6671305BB48C1A9A8C6B83592E9E2F79E76768626C 4F6F75A17F8A6D0B96336C274EF075D2517B68376F3E90808170599674760000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 52 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000064475C2790657A918C2359DA54AC8200836F898180006930564E80367237 91CE51B64E5F987563964E1A53F666F3814B591C6DB24E0058F9533B63D694F1 4F9D4F0A886398905937905779FB4EEA80F075916C825B9C59E85F5D69058681 501A5DF24E5977E34EE5827A6291661390915C794EBF5F7981C69038808475AB 4EA688D4610F6BC55FC64E4976CA6EA28BE38BAE8C0A8BD15F027FFC7FCC7ECE 8335836B56E06BB797F3963459FB541F94F66DEB5BC5996E5C395F1596900000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 53 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000537082F16A315A749E705E947F2883B984248425836787478FCE8D6276C8 5F719896786C662054DF62E54F6381C375C85EB896CD8E0A86F9548F6CF36D8C 6C38607F52C775285E7D4F1860A05FE75C24753190AE94C072B96CB96E389149 670953CB53F34F5191C98BF153C85E7C8FC26DE44E8E76C26986865E611A8206 4F594FDE903E9C7C61096E1D6E1496854E885A3196E84E0E5C7F79B95B878BED 7FBD738957DF828B90C15401904755BB5CEA5FA161086B3272F180B28A890000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 54 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006D745BD388D598848C6B9A6D9E336E0A51A4514357A38881539F63F48F95 56ED54585706733F6E907F188FDC82D1613F6028966266F07EA68D8A8DC394A5 5CB37CA4670860A6960580184E9190E75300966851418FD08574915D665597F5 5B55531D78386742683D54C9707E5BB08F7D518D572854B1651266828D5E8D43 810F846C906D7CDF51FF85FB67A365E96FA186A48E81566A90207682707671E5 8D2362E952196CFD8D3C600E589E618E66FE8D60624E55B36E23672D8F670000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 55 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000094E195F87728680569A8548B4E4D70B88BC86458658B5B857A84503A5BE8 77BB6BE18A797C986CBE76CF65A98F975D2D5C5586386808536062187AD96E5B 7EFD6A1F7AE05F706F335F20638C6DA867564E085E108D264ED780C07634969C 62DB662D627E6CBC8D7571677F695146808753EC906E629854F286F08F998005 951785178FD96D5973CD659F771F7504782781FB8D1E94884FA6679575B98BCA 9707632F9547963584B8632377415F8172F04E896014657462EF6B63653F0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 56 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005E2775C790D18BC1829D679D652F5431871877E580A281026C414E4B7EC7 804C76F4690D6B966267503C4F84574063076B628DBE53EA65E87EB85FD7631A 63B781F381F47F6E5E1C5CD95236667A79E97A1A8D28709975D46EDE6CBB7A92 4E2D76C55FE0949F88777EC879CD80BF91CD4EF24F17821F54685DDE6D328BCC 7CA58F7480985E1A549276B15B99663C9AA473E0682A86DB6731732A8BF88BDB 90107AF970DB716E62C477A956314E3B845767F152A986C08D2E94F87B510000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 57 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004F4F6CE8795D9A7B6293722A62FD4E1378168F6C64B08D5A7BC668695E84 88C55986649E58EE72B6690E95258FFD8D5857607F008C0651C6634962D95353 684C74228301914C55447740707C6D4A517954A88D4459FF6ECB6DC45B5C7D2B 4ED47C7D6ED35B5081EA6E0D5B579B0368D58E2A5B977EFC603B7EB590B98D70 594F63CD79DF8DB3535265CF79568BC5963B7EC494BB7E825634918967007F6A 5C0A907566285DE64F5067DE505A4F5C57505EA7000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 58 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004E8D4E0C51404E105EFF53454E154E984E1E9B325B6C56694E2879BA4E3F 53154E47592D723B536E6C1056DF80E499976BD3777E9F174E364E9F9F104E5C 4E694E9382885B5B556C560F4EC4538D539D53A353A553AE97658D5D531A53F5 5326532E533E8D5C5366536352025208520E522D5233523F5240524C525E5261 525C84AF527D528252815290529351827F544EBB4EC34EC94EC24EE84EE14EEB 4EDE4F1B4EF34F224F644EF54F254F274F094F2B4F5E4F6765384F5A4F5D0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 59 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004F5F4F574F324F3D4F764F744F914F894F834F8F4F7E4F7B4FAA4F7C4FAC 4F944FE64FE84FEA4FC54FDA4FE34FDC4FD14FDF4FF85029504C4FF3502C500F 502E502D4FFE501C500C50255028507E504350555048504E506C507B50A550A7 50A950BA50D6510650ED50EC50E650EE5107510B4EDD6C3D4F584F654FCE9FA0 6C467C74516E5DFD9EC999985181591452F9530D8A07531051EB591951554EA0 51564EB3886E88A44EB5811488D279805B3488037FB851AB51B151BD51BC0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 5A 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000051C7519651A251A58BA08BA68BA78BAA8BB48BB58BB78BC28BC38BCB8BCF 8BCE8BD28BD38BD48BD68BD88BD98BDC8BDF8BE08BE48BE88BE98BEE8BF08BF3 8BF68BF98BFC8BFF8C008C028C048C078C0C8C0F8C118C128C148C158C168C19 8C1B8C188C1D8C1F8C208C218C258C278C2A8C2B8C2E8C2F8C328C338C358C36 5369537A961D962296219631962A963D963C964296499654965F9667966C9672 96749688968D969796B09097909B909D909990AC90A190B490B390B690BA0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 5B 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000090B890B090CF90C590BE90D090C490C790D390E690E290DC90D790DB90EB 90EF90FE91049122911E91239131912F913991439146520D594252A252AC52AD 52BE54FF52D052D652F053DF71EE77CD5EF451F551FC9B2F53B65F01755A5DEF 574C57A957A1587E58BC58C558D15729572C572A57335739572E572F575C573B 574257695785576B5786577C577B5768576D5776577357AD57A4578C57B257CF 57A757B4579357A057D557D857DA57D957D257B857F457EF57F857E457DD0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 5C 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000580B580D57FD57ED5800581E5819584458205865586C58815889589A5880 99A89F1961FF8279827D827F828F828A82A88284828E82918297829982AB82B8 82BE82B082C882CA82E3829882B782AE82CB82CC82C182A982B482A182AA829F 82C482CE82A482E1830982F782E4830F830782DC82F482D282D8830C82FB82D3 8311831A83068314831582E082D5831C8351835B835C83088392833C83348331 839B835E832F834F83478343835F834083178360832D833A8333836683650000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 5D 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008368831B8369836C836A836D836E83B0837883B383B483A083AA8393839C 8385837C83B683A9837D83B8837B8398839E83A883BA83BC83C1840183E583D8 58078418840B83DD83FD83D6841C84388411840683D483DF840F840383F883F9 83EA83C583C0842683F083E1845C8451845A8459847384878488847A84898478 843C844684698476848C848E8431846D84C184CD84D084E684BD84D384CA84BF 84BA84E084A184B984B4849784E584E3850C750D853884F08539851F853A0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 5E 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008556853B84FF84FC8559854885688564855E857A77A285438572857B85A4 85A88587858F857985AE859C858585B985B785B085D385C185DC85FF86278605 86298616863C5EFE5F08593C594180375955595A5958530F5C225C255C2C5C34 624C626A629F62BB62CA62DA62D762EE632262F66339634B634363AD63F66371 637A638E63B4636D63AC638A636963AE63BC63F263F863E063FF63C463DE63CE 645263C663BE64456441640B641B6420640C64266421645E6484646D64960000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 5F 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000647A64B764B8649964BA64C064D064D764E464E265096525652E5F0B5FD2 75195F11535F53F153FD53E953E853FB541254165406544B5452545354545456 54435421545754595423543254825494547754715464549A549B548454765466 549D54D054AD54C254B454D254A754A654D354D4547254A354D554BB54BF54CC 54D954DA54DC54A954AA54A454DD54CF54DE551B54E7552054FD551454F35522 5523550F55115527552A5567558F55B55549556D55415555553F5550553C0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 60 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005537555655755576557755335530555C558B55D2558355B155B955885581 559F557E55D65591557B55DF55BD55BE5594559955EA55F755C9561F55D155EB 55EC55D455E655DD55C455EF55E555F255F355CC55CD55E855F555E48F94561E 5608560C56015624562355FE56005627562D565856395657562C564D56625659 565C564C5654568656645671566B567B567C5685569356AF56D456D756DD56E1 56F556EB56F956FF5704570A5709571C5E0F5E195E145E115E315E3B5E3C0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 61 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005E375E445E545E5B5E5E5E615C8C5C7A5C8D5C905C965C885C985C995C91 5C9A5C9C5CB55CA25CBD5CAC5CAB5CB15CA35CC15CB75CC45CD25CE45CCB5CE5 5D025D035D275D265D2E5D245D1E5D065D1B5D585D3E5D345D3D5D6C5D5B5D6F 5D5D5D6B5D4B5D4A5D695D745D825D995D9D8C735DB75DC55F735F775F825F87 5F895F8C5F955F995F9C5FA85FAD5FB55FBC88625F6172AD72B072B472B772B8 72C372C172CE72CD72D272E872EF72E972F272F472F7730172F3730372FA0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 62 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000072FB731773137321730A731E731D7315732273397325732C733873317350 734D73577360736C736F737E821B592598E7592459029963996799689969996A 996B996C99749977997D998099849987998A998D999099919993999499955E80 5E915E8B5E965EA55EA05EB95EB55EBE5EB38D535ED25ED15EDB5EE85EEA81BA 5FC45FC95FD65FCF60035FEE60045FE15FE45FFE600560065FEA5FED5FF86019 60356026601B600F600D6029602B600A603F602160786079607B607A60420000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 63 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000606A607D6096609A60AD609D60836092608C609B60EC60BB60B160DD60D8 60C660DA60B4612061266115612360F46100610E612B614A617561AC619461A7 61B761D461F55FDD96B395E995EB95F195F395F595F695FC95FE960396049606 9608960A960B960C960D960F96129615961696179619961A4E2C723F62156C35 6C546C5C6C4A6CA36C856C906C946C8C6C686C696C746C766C866CA96CD06CD4 6CAD6CF76CF86CF16CD76CB26CE06CD66CFA6CEB6CEE6CB16CD36CEF6CFE0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 64 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006D396D276D0C6D436D486D076D046D196D0E6D2B6D4D6D2E6D356D1A6D4F 6D526D546D336D916D6F6D9E6DA06D5E6D936D946D5C6D606D7C6D636E1A6DC7 6DC56DDE6E0E6DBF6DE06E116DE66DDD6DD96E166DAB6E0C6DAE6E2B6E6E6E4E 6E6B6EB26E5F6E866E536E546E326E256E446EDF6EB16E986EE06F2D6EE26EA5 6EA76EBD6EBB6EB76ED76EB46ECF6E8F6EC26E9F6F626F466F476F246F156EF9 6F2F6F366F4B6F746F2A6F096F296F896F8D6F8C6F786F726F7C6F7A6FD10000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 65 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006FC96FA76FB96FB66FC26FE16FEE6FDE6FE06FEF701A7023701B70397035 704F705E5B805B845B955B935BA55BB8752F9A9E64345BE45BEE89305BF08E47 8B078FB68FD38FD58FE58FEE8FE48FE98FE68FF38FE890059004900B90269011 900D9016902190359036902D902F9044905190529050906890589062905B66B9 9074907D908290889083908B5F505F575F565F585C3B54AB5C505C595B715C63 5C667FBC5F2A5F295F2D82745F3C9B3B5C6E59815983598D59A959AA59A30000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 66 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000599759CA59AB599E59A459D259B259AF59D759BE5A055A0659DD5A0859E3 59D859F95A0C5A095A325A345A115A235A135A405A675A4A5A555A3C5A625A75 80EC5AAA5A9B5A775A7A5ABE5AEB5AB25AD25AD45AB85AE05AE35AF15AD65AE6 5AD85ADC5B095B175B165B325B375B405C155C1C5B5A5B655B735B515B535B62 9A759A779A789A7A9A7F9A7D9A809A819A859A889A8A9A909A929A939A969A98 9A9B9A9C9A9D9A9F9AA09AA29AA39AA59AA77E9F7EA17EA37EA57EA87EA90000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 67 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00007EAD7EB07EBE7EC07EC17EC27EC97ECB7ECC7ED07ED47ED77EDB7EE07EE1 7EE87EEB7EEE7EEF7EF17EF27F0D7EF67EFA7EFB7EFE7F017F027F037F077F08 7F0B7F0C7F0F7F117F127F177F197F1C7F1B7F1F7F217F227F237F247F257F26 7F277F2A7F2B7F2C7F2D7F2F7F307F317F327F337F355E7A757F5DDB753E9095 738E739173AE73A2739F73CF73C273D173B773B373C073C973C873E573D9987C 740A73E973E773DE73BA73F2740F742A745B7426742574287430742E742C0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 68 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000741B741A7441745C7457745574597477746D747E749C748E748074817487 748B749E74A874A9749074A774D274BA97EA97EB97EC674C6753675E67486769 67A56787676A6773679867A7677567A8679E67AD678B6777677C67F0680967D8 680A67E967B0680C67D967B567DA67B367DD680067C367B867E2680E67C167FD 6832683368606861684E6862684468646883681D68556866684168676840683E 684A6849682968B5688F687468776893686B68C2696E68FC691F692068F90000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 69 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000692468F0690B6901695768E369106971693969606942695D6984696B6980 69986978693469CC6987698869CE6989696669636979699B69A769BB69AB69AD 69D469B169C169CA69DF699569E0698D69FF6A2F69ED6A176A186A6569F26A44 6A3E6AA06A506A5B6A356A8E6A796A3D6A286A586A7C6A916A906AA96A976AAB 733773526B816B826B876B846B926B936B8D6B9A6B9B6BA16BAA8F6B8F6D8F71 8F728F738F758F768F788F778F798F7A8F7C8F7E8F818F828F848F878F8B0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 6A 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008F8D8F8E8F8F8F988F9A8ECE620B6217621B621F6222622162256224622C 81E774EF74F474FF750F75117513653465EE65EF65F0660A6619677266036615 6600708566F7661D66346631663666358006665F66546641664F665666616657 66776684668C66A7669D66BE66DB66DC66E666E98D328D338D368D3B8D3D8D40 8D458D468D488D498D478D4D8D558D5989C789CA89CB89CC89CE89CF89D089D1 726E729F725D7266726F727E727F7284728B728D728F72926308633263B00000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 6B 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000643F64D880046BEA6BF36BFD6BF56BF96C056C076C066C0D6C156C186C19 6C1A6C216C296C246C2A6C3265356555656B724D72527256723086625216809F 809C809380BC670A80BD80B180AB80AD80B480B780E780E880E980EA80DB80C2 80C480D980CD80D7671080DD80EB80F180F480ED810D810E80F280FC67158112 8C5A8136811E812C811881328148814C815381748159815A817181608169817C 817D816D8167584D5AB58188818281916ED581A381AA81CC672681CA81BB0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 6C 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000081C181A66B246B376B396B436B466B5998D198D298D398D598D998DA6BB3 5F406BC289F365909F51659365BC65C665C465C365CC65CE65D265D67080709C 7096709D70BB70C070B770AB70B170E870CA711071137116712F71317173715C 716871457172714A7178717A719871B371B571A871A071E071D471E771F9721D 7228706C7118716671B9623E623D624362486249793B794079467949795B795C 7953795A796279577960796F7967797A7985798A799A79A779B35FD15FD00000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 6D 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000603C605D605A606760416059606360AB6106610D615D61A9619D61CB61D1 62068080807F6C936CF66DFC77F677F87800780978177818781165AB782D781C 781D7839783A783B781F783C7825782C78237829784E786D7856785778267850 7847784C786A789B7893789A7887789C78A178A378B278B978A578D478D978C9 78EC78F2790578F479137924791E79349F9B9EF99EFB9EFC76F17704770D76F9 77077708771A77227719772D7726773577387750775177477743775A77680000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 6E 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000077627765777F778D777D7780778C7791779F77A077B077B577BD753A7540 754E754B7548755B7572757975837F587F617F5F8A487F687F747F717F797F81 7F7E76CD76E58832948594869487948B948A948C948D948F9490949494979495 949A949B949C94A394A494AB94AA94AD94AC94AF94B094B294B494B694B794B8 94B994BA94BC94BD94BF94C494C894C994CA94CB94CC94CD94CE94D094D194D2 94D594D694D794D994D894DB94DE94DF94E094E294E494E594E794E894EA0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 6F 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000094E994EB94EE94EF94F394F494F594F794F994FC94FD94FF950395029506 95079509950A950D950E950F951295139514951595169518951B951D951E951F 9522952A952B9529952C953195329534953695379538953C953E953F95429535 9544954595469549954C954E954F9552955395549556955795589559955B955E 955F955D95619562956495659566956795689569956A956B956C956F95719572 9573953A77E777EC96C979D579ED79E379EB7A065D477A037A027A1E7A140000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 70 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00007A397A377A519ECF99A57A707688768E7693769976A474DE74E0752C9E20 9E229E289E299E2A9E2B9E2C9E329E319E369E389E379E399E3A9E3E9E419E42 9E449E469E479E489E499E4B9E4C9E4E9E519E559E579E5A9E5B9E5C9E5E9E63 9E669E679E689E699E6A9E6B9E6C9E719E6D9E7375927594759675A0759D75AC 75A375B375B475B875C475B175B075C375C275D675CD75E375E875E675E475EB 75E7760375F175FC75FF761076007605760C7617760A76257618761576190000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 71 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000761B763C762276207640762D7630763F76357643763E7633764D765E7654 765C7656766B766F7FCA7AE67A787A797A807A867A887A957AA67AA07AAC7AA8 7AAD7AB3886488698872887D887F888288A288C688B788BC88C988E288CE88E3 88E588F1891A88FC88E888FE88F0892189198913891B890A8934892B89368941 8966897B758B80E576B276B477DC801280148016801C80208022802580268027 802980288031800B803580438046804D80528069807189839878988098830000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 72 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009889988C988D988F9894989A989B989E989F98A198A298A598A6864D8654 866C866E867F867A867C867B86A8868D868B86AC869D86A786A386AA869386A9 86B686C486B586CE86B086BA86B186AF86C986CF86B486E986F186F286ED86F3 86D0871386DE86F486DF86D886D18703870786F88708870A870D87098723873B 871E8725872E871A873E87488734873187298737873F87828722877D877E877B 87608770874C876E878B87538763877C876487598765879387AF87A887D20000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 73 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000087C68788878587AD8797878387AB87E587AC87B587B387CB87D387BD87D1 87C087CA87DB87EA87E087EE8816881387FE880A881B88218839883C7F367F42 7F447F4582107AFA7AFD7B087B037B047B157B0A7B2B7B0F7B477B387B2A7B19 7B2E7B317B207B257B247B337B3E7B1E7B587B5A7B457B757B4C7B5D7B607B6E 7B7B7B627B727B717B907BA67BA77BB87BAC7B9D7BA87B857BAA7B9C7BA27BAB 7BB47BD17BC17BCC7BDD7BDA7BE57BE67BEA7C0C7BFE7BFC7C0F7C167C0B0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 74 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00007C1F7C2A7C267C387C417C4081FE82018202820481EC8844822182228223 822D822F8228822B8238823B82338234823E82448249824B824F825A825F8268 887E8885888888D888DF895E7F9D7F9F7FA77FAF7FB07FB27C7C65497C917C9D 7C9C7C9E7CA27CB27CBC7CBD7CC17CC77CCC7CCD7CC87CC57CD77CE8826E66A8 7FBF7FCE7FD57FE57FE17FE67FE97FEE7FF37CF87D777DA67DAE7E477E9B9EB8 9EB48D738D848D948D918DB18D678D6D8C478C49914A9150914E914F91640000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 75 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009162916191709169916F917D917E917291749179918C91859190918D9191 91A291A391AA91AD91AE91AF91B591B491BA8C559E7E8DB88DEB8E058E598E69 8DB58DBF8DBC8DBA8DC48DD68DD78DDA8DDE8DCE8DCF8DDB8DC68DEC8DF78DF8 8DE38DF98DFB8DE48E098DFD8E148E1D8E1F8E2C8E2E8E238E2F8E3A8E408E39 8E358E3D8E318E498E418E428E518E528E4A8E708E768E7C8E6F8E748E858E8F 8E948E908E9C8E9E8C788C828C8A8C858C988C94659B89D689DE89DA89DC0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 76 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000089E589EB89EF8A3E8B26975396E996F396EF970697019708970F970E972A 972D9730973E9F809F839F859F869F879F889F899F8A9F8C9EFE9F0B9F0D96B9 96BC96BD96CE96D277BF96E0928E92AE92C8933E936A93CA938F943E946B9C7F 9C829C859C869C879C887A239C8B9C8E9C909C919C929C949C959C9A9C9B9C9E 9C9F9CA09CA19CA29CA39CA59CA69CA79CA89CA99CAB9CAD9CAE9CB09CB19CB2 9CB39CB49CB59CB69CB79CBA9CBB9CBC9CBD9CC49CC59CC69CC79CCA9CCB0000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 77 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009CCC9CCD9CCE9CCF9CD09CD39CD49CD59CD79CD89CD99CDC9CDD9CDF9CE2 977C978597919792979497AF97AB97A397B297B49AB19AB09AB79E589AB69ABA 9ABC9AC19AC09AC59AC29ACB9ACC9AD19B459B439B479B499B489B4D9B5198E8 990D992E995599549ADF9AE19AE69AEF9AEB9AFB9AED9AF99B089B0F9B139B1F 9B239EBD9EBE7E3B9E829E879E889E8B9E9293D69E9D9E9F9EDB9EDC9EDD9EE0 9EDF9EE29EE99EE79EE59EEA9EEF9F229F2C9F2F9F399F379F3D9F3E9F440000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 |
Changes to library/encoding/gb2312.enc.
|
| | < > | < > > > > > > > > > > > > > > > > > > > > > > > > > > > < > < > < > < > < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 | # Encoding file: euc-cn, multi-byte M 003F 0 82 00 0000000100020003000400050006000700080009000A000B000C000D000E000F 0010001100120013001400150016001700180019001A001B001C001D001E001F 0020002100220023002400250026002700280029002A002B002C002D002E002F 0030003100320033003400350036003700380039003A003B003C003D003E003F 0040004100420043004400450046004700480049004A004B004C004D004E004F 0050005100520053005400550056005700580059005A005B005C005D005E005F 0060006100620063006400650066006700680069006A006B006C006D006E006F 0070007100720073007400750076007700780079007A007B007C007D007E007F 0080008100820083008400850086008700880089008A008B008C008D008E008F 0090009100920093009400950096009700980099009A009B009C009D009E009F 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 A1 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000030003001300230FB02C902C700A8300330052015FF5E2225202620182019 201C201D3014301530083009300A300B300C300D300E300F3016301730103011 00B100D700F72236222722282211220F222A222922082237221A22A522252220 23122299222B222E2261224C2248223D221D2260226E226F22642265221E2235 22342642264000B0203220332103FF0400A4FFE0FFE1203000A7211626062605 25CB25CF25CE25C725C625A125A025B325B2203B219221902191219330130000 A2 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000024882489248A248B248C248D248E248F2490249124922493249424952496 249724982499249A249B247424752476247724782479247A247B247C247D247E 247F248024812482248324842485248624872460246124622463246424652466 2467246824690000000032203221322232233224322532263227322832290000 00002160216121622163216421652166216721682169216A216B000000000000 A3 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000FF01FF02FF03FFE5FF05FF06FF07FF08FF09FF0AFF0BFF0CFF0DFF0EFF0F FF10FF11FF12FF13FF14FF15FF16FF17FF18FF19FF1AFF1BFF1CFF1DFF1EFF1F FF20FF21FF22FF23FF24FF25FF26FF27FF28FF29FF2AFF2BFF2CFF2DFF2EFF2F FF30FF31FF32FF33FF34FF35FF36FF37FF38FF39FF3AFF3BFF3CFF3DFF3EFF3F FF40FF41FF42FF43FF44FF45FF46FF47FF48FF49FF4AFF4BFF4CFF4DFF4EFF4F FF50FF51FF52FF53FF54FF55FF56FF57FF58FF59FF5AFF5BFF5CFF5DFFE30000 A4 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000304130423043304430453046304730483049304A304B304C304D304E304F 3050305130523053305430553056305730583059305A305B305C305D305E305F 3060306130623063306430653066306730683069306A306B306C306D306E306F 3070307130723073307430753076307730783079307A307B307C307D307E307F 3080308130823083308430853086308730883089308A308B308C308D308E308F 3090309130923093000000000000000000000000000000000000000000000000 A5 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000030A130A230A330A430A530A630A730A830A930AA30AB30AC30AD30AE30AF 30B030B130B230B330B430B530B630B730B830B930BA30BB30BC30BD30BE30BF 30C030C130C230C330C430C530C630C730C830C930CA30CB30CC30CD30CE30CF 30D030D130D230D330D430D530D630D730D830D930DA30DB30DC30DD30DE30DF 30E030E130E230E330E430E530E630E730E830E930EA30EB30EC30ED30EE30EF 30F030F130F230F330F430F530F6000000000000000000000000000000000000 A6 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000039103920393039403950396039703980399039A039B039C039D039E039F 03A003A103A303A403A503A603A703A803A90000000000000000000000000000 000003B103B203B303B403B503B603B703B803B903BA03BB03BC03BD03BE03BF 03C003C103C303C403C503C603C703C803C90000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 A7 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000004100411041204130414041504010416041704180419041A041B041C041D 041E041F0420042104220423042404250426042704280429042A042B042C042D 042E042F00000000000000000000000000000000000000000000000000000000 000004300431043204330434043504510436043704380439043A043B043C043D 043E043F0440044104420443044404450446044704480449044A044B044C044D 044E044F00000000000000000000000000000000000000000000000000000000 A8 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000010100E101CE00E0011300E9011B00E8012B00ED01D000EC014D00F301D2 00F2016B00FA01D400F901D601D801DA01DC00FC00EA00000000000000000000 0000000000000000000031053106310731083109310A310B310C310D310E310F 3110311131123113311431153116311731183119311A311B311C311D311E311F 3120312131223123312431253126312731283129000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 A9 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00000000000000002500250125022503250425052506250725082509250A250B 250C250D250E250F2510251125122513251425152516251725182519251A251B 251C251D251E251F2520252125222523252425252526252725282529252A252B 252C252D252E252F2530253125322533253425352536253725382539253A253B 253C253D253E253F2540254125422543254425452546254725482549254A254B 0000000000000000000000000000000000000000000000000000000000000000 B0 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000554A963F57C3632854CE550954C07691764C853C77EE827E788D72319698 978D6C285B894FFA630966975CB880FA684880AE660276CE51F9655671AC7FF1 888450B2596561CA6FB382AD634C625253ED54277B06516B75A45DF462D48DCB 9776628A8019575D97387F627238767D67CF767E64464F708D2562DC7A176591 73ED642C6273822C9881677F7248626E62CC4F3474E3534A529E7ECA90A65E2E 6886699C81807ED168D278C5868C9551508D8C2482DE80DE5305891252650000 B1 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000858496F94FDD582199715B9D62B162A566B48C799C8D7206676F789160B2 535153178F8880CC8D1D94A1500D72C8590760EB711988AB595482EF672C7B28 5D297EF7752D6CF58E668FF8903C9F3B6BD491197B145F7C78A784D6853D6BD5 6BD96BD65E015E8775F995ED655D5F0A5FC58F9F58C181C2907F965B97AD8FB9 7F168D2C62414FBF53D8535E8FA88FA98FAB904D68075F6A819888689CD6618B 522B762A5F6C658C6FD26EE85BBE6448517551B067C44E1979C9997C70B30000 B2 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000075C55E7673BB83E064AD62E894B56CE2535A52C3640F94C27B944F2F5E1B 82368116818A6E246CCA9A736355535C54FA886557E04E0D5E036B657C3F90E8 601664E6731C88C16750624D8D22776C8E2991C75F6983DC8521991053C28695 6B8B60ED60E8707F82CD82314ED36CA785CF64CD7CD969FD66F9834953957B56 4FA7518C6D4B5C428E6D63D253C9832C833667E578B4643D5BDF5C945DEE8BE7 62C667F48C7A640063BA8749998B8C177F2094F24EA7961098A4660C73160000 B3 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000573A5C1D5E38957F507F80A05382655E7545553150218D856284949E671D 56326F6E5DE2543570928F66626F64A463A35F7B6F8890F481E38FB05C186668 5FF16C8996488D81886C649179F057CE6A59621054484E587A0B60E96F848BDA 627F901E9A8B79E4540375F4630153196C608FDF5F1B9A70803B9F7F4F885C3A 8D647FC565A570BD514551B2866B5D075BA062BD916C75748E0C7A2061017B79 4EC77EF877854E1181ED521D51FA6A7153A88E87950496CF6EC19664695A0000 B4 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000784050A877D7641089E6590463E35DDD7A7F693D4F20823955984E3275AE 7A975E625E8A95EF521B5439708A6376952457826625693F918755076DF37EAF 882262337EF075B5832878C196CC8F9E614874F78BCD6B64523A8D506B21806A 847156F153064ECE4E1B51D17C97918B7C074FC38E7F7BE17A9C64675D1450AC 810676017CB96DEC7FE067515B585BF878CB64AE641363AA632B9519642D8FBE 7B5476296253592754466B7950A362345E266B864EE38D37888B5F85902E0000 B5 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006020803D62C54E39535590F863B880C665E66C2E4F4660EE6DE18BDE5F39 86CB5F536321515A83616863520063638E4850125C9B79775BFC52307A3B60BC 905376D75FB75F9776848E6C706F767B7B4977AA51F3909358244F4E6EF48FEA 654C7B1B72C46DA47FDF5AE162B55E95573084827B2C5E1D5F1F90127F1498A0 63826EC7789870B95178975B57AB75354F4375385E9760E659606DC06BBF7889 53FC96D551CB52016389540A94938C038DCC7239789F87768FED8C0D53E00000 B6 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004E0176EF53EE948998769F0E952D5B9A8BA24E224E1C51AC846361C252A8 680B4F97606B51BB6D1E515C6296659796618C46901775D890FD77636BD2728A 72EC8BFB583577798D4C675C9540809A5EA66E2159927AEF77ED953B6BB565AD 7F0E58065151961F5BF958A954288E726566987F56E4949D76FE9041638754C6 591A593A579B8EB267358DFA8235524160F0581586FE5CE89E454FC4989D8BB9 5A2560765384627C904F9102997F6069800C513F80335C1499756D314E8C0000 B7 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008D3053D17F5A7B4F4F104E4F96006CD573D085E95E06756A7FFB6A0A77FE 94927E4151E170E653CD8FD483038D2972AF996D6CDB574A82B365B980AA623F 963259A84EFF8BBF7EBA653E83F2975E556198DE80A5532A8BFD542080BA5E9F 6CB88D3982AC915A54296C1B52067EB7575F711A6C7E7C89594B4EFD5FFF6124 7CAA4E305C0167AB87025CF0950B98CE75AF70FD902251AF7F1D8BBD594951E4 4F5B5426592B657780A45B75627662C28F905E456C1F7B264F0F4FD8670D0000 B8 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006D6E6DAA798F88B15F17752B629A8F854FEF91DC65A7812F81515E9C8150 8D74526F89868D4B590D50854ED8961C723681798D1F5BCC8BA3964459877F1A 54905676560E8BE565396982949976D66E895E727518674667D17AFF809D8D76 611F79C665628D635188521A94A27F38809B7EB25C976E2F67607BD9768B9AD8 818F7F947CD5641E95507A3F544A54E56B4C640162089E3D80F3759952729769 845B683C86E49601969494EC4E2A54047ED968398DDF801566F45E9A7FB90000 B9 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000057C2803F68975DE5653B529F606D9F9A4F9B8EAC516C5BAB5F135DE96C5E 62F18D21517194A952FE6C9F82DF72D757A267848D2D591F8F9C83C754957B8D 4F306CBD5B6459D19F1353E486CA9AA88C3780A16545987E56FA96C7522E74DC 52505BE1630289024E5662D0602A68FA51735B9851A089C27BA199867F5060EF 704C8D2F51495E7F901B747089C4572D78455F529F9F95FA8F689B3C8BE17678 684267DC8DEA8D35523D8F8A6EDA68CD950590ED56FD679C88F98FC754C80000 BA 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009AB85B696D776C264EA55BB39A87916361A890AF97E9542B6DB55BD251FD 558A7F557FF064BC634D65F161BE608D710A6C576C49592F676D822A58D5568E 8C6A6BEB90DD597D801753F76D695475559D837783CF683879BE548C4F555408 76D28C8996026CB36DB88D6B89109E648D3A563F9ED175D55F8872E0606854FC 4EA86A2A886160528F7054C470D886799E3F6D2A5B8F5F187EA255894FAF7334 543C539A5019540E547C4E4E5FFD745A58F6846B80E1877472D07CCA6E560000 BB 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005F27864E552C62A44E926CAA623782B154D7534E733E6ED1753B52125316 8BDD69D05F8A60006DEE574F6B2273AF68538FD87F13636260A3552475EA8C62 71156DA35BA65E7B8352614C9EC478FA87577C27768751F060F6714C66435E4C 604D8C0E707063258F895FBD606286D456DE6BC160946167534960E066668D3F 79FD4F1A70E96C478BB38BF27ED88364660F5A5A9B426D516DF78C416D3B4F19 706B83B7621660D1970D8D27797851FB573E57FA673A75787A3D79EF7B950000 BC 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000808C99658FF96FC08BA59E2159EC7EE97F095409678168D88F917C4D96C6 53CA602575BE6C7253735AC97EA7632451E0810A5DF184DF628051805B634F0E 796D524260B86D4E5BC45BC28BA18BB065E25FCC964559937EE77EAA560967B7 59394F735BB652A0835A988A8D3E753294BE50477A3C4EF767B69A7E5AC16B7C 76D1575A5C167B3A95F4714E517C80A9827059787F04832768C067EC78B17877 62E363617B804FED526A51CF835069DB92748DF58D3189C1952E7BAD4EF60000 BD 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000506582305251996F6E106E856DA75EFA50F559DC5C066D466C5F7586848B 686859568BB253209171964D854969127901712680F64EA490CA6D479A845A07 56BC640594F077EB4FA5811A72E189D2997A7F347EDE527F655991758F7F8F83 53EB7A9663ED63A5768679F888579636622A52AB8282685467706377776B7AED 6D017ED389E359D0621285C982A5754C501F4ECB75A58BEB5C4A5DFE7B4B65A4 91D14ECA6D25895F7D2795264EC58C288FDB9773664B79818FD170EC6D780000 BE 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005C3D52B283465162830E775B66769CB84EAC60CA7CBE7CB37ECF4E958B66 666F988897595883656C955C5F8475C997567ADF7ADE51C070AF7A9863EA7A76 7EA0739697ED4E4570784E5D915253A9655165E781FC8205548E5C31759A97A0 62D872D975BD5C459A7983CA5C40548077E94E3E6CAE805A62D2636E5DE85177 8DDD8E1E952F4FF153E560E770AC526763509E435A1F5026773753777EE26485 652B628963985014723589C951B38BC07EDD574783CC94A7519B541B5CFB0000 BF 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004FCA7AE36D5A90E19A8F55805496536154AF5F0063E9697751EF6168520A 582A52D8574E780D770B5EB761777CE0625B62974EA27095800362F770E49760 577782DB67EF68F578D5989779D158F354B353EF6E34514B523B5BA28BFE80AF 554357A660735751542D7A7A60505B5463A762A053E362635BC767AF54ED7A9F 82E691775E9388E4593857AE630E8DE880EF57577B774FA95FEB5BBD6B3E5321 7B5072C2684677FF773665F751B54E8F76D45CBF7AA58475594E9B4150800000 C0 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000998861276E8357646606634656F062EC62695ED39614578362C955878721 814A8FA3556683B167658D5684DD5A6A680F62E67BEE961151706F9C8C3063FD 89C861D27F0670C26EE57405699472FC5ECA90CE67176D6A635E52B372628001 4F6C59E5916A70D96D9D52D24E5096F7956D857E78CA7D2F5121579264C2808B 7C7B6CEA68F1695E51B7539868A872819ECE7BF172F879BB6F137406674E91CC 9CA4793C83898354540F68174E3D538952B1783E5386522950884F8B4FD00000 C1 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000075E27ACB7C926CA596B6529B748354E94FE9805483B28FDE95705EC9601C 6D9F5E18655B813894FE604B70BC7EC37CAE51C968817CB1826F4E248F8691CF 667E4EAE8C0564A9804A50DA759771CE5BE58FBD6F664E86648295635ED66599 521788C270C852A3730E7433679778F797164E3490BB9CDE6DCB51DB8D41541D 62CE73B283F196F69F8494C34F367F9A51CC707596755CAD988653E64EE46E9C 740969B4786B998F7559521876246D4167F3516D9F99804B54997B3C7ABF0000 C2 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009686578462E29647697C5A0464027BD36F0F964B82A6536298855E907089 63B35364864F9C819E93788C97328DEF8D429E7F6F5E79845F559646622E9A74 541594DD4FA365C55C655C617F1586516C2F5F8B73876EE47EFF5CE6631B5B6A 6EE653754E7163A0756562A18F6E4F264ED16CA67EB68BBA841D87BA7F57903B 95237BA99AA188F8843D6D1B9A867EDC59889EBB739B780186829A6C9A82561B 541757CB4E709EA653568FC881097792999286EE6EE1851366FC61626F2B0000 C3 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008C298292832B76F26C135FD983BD732B8305951A6BDB77DB94C6536F8302 51925E3D8C8C8D384E4873AB679A68859176970971646CA177095A9295416BCF 7F8E66275BD059B95A9A95E895F74EEC840C84996AAC76DF9530731B68A65B5F 772F919A97617CDC8FF78C1C5F257C7379D889C56CCC871C5BC65E4268C97720 7EF55195514D52C95A297F05976282D763CF778485D079D26E3A5E9959998511 706D6C1162BF76BF654F60AF95FD660E879F9E2394ED540D547D8C2C64780000 C4 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000647986116A21819C78E864699B5462B9672B83AB58A89ED86CAB6F205BDE 964C8C0B725F67D062C772614EA959C66BCD589366AE5E5552DF6155672876EE 776672677A4662FF54EA545094A090A35A1C7EB36C164E435976801059485357 753796BE56CA63208111607C95F96DD65462998151855AE980FD59AE9713502A 6CE55C3C62DF4F60533F817B90066EBA852B62C85E7478BE64B5637B5FF55A18 917F9E1F5C3F634F80425B7D556E954A954D6D8560A867E072DE51DD5B810000 C5 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000062E76CDE725B626D94AE7EBD81136D53519C5F04597452AA601259736696 8650759F632A61E67CEF8BFA54E66B279E256BB485D5545550766CA4556A8DB4 722C5E156015743662CD6392724C5F986E436D3E65006F5876D878D076FC7554 522453DB4E535E9E65C1802A80D6629B5486522870AE888D8DD16CE1547880DA 57F988F48D54966A914D4F696C9B55B776C6783062A870F96F8E5F6D84EC68DA 787C7BF781A8670B9E4F636778B0576F78129739627962AB528874356BD70000 C6 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005564813E75B276AE533975DE50FB5C418B6C7BC7504F72479A9798D86F02 74E27968648777A562FC98918D2B54C180584E52576A82F9840D5E7351ED74F6 8BC45C4F57616CFC98875A4678349B448FEB7C955256625194FA4EC683868461 83E984B257D467345703666E6D668C3166DD7011671F6B3A6816621A59BB4E03 51C46F0667D26C8F517668CB59476B6775665D0E81109F5065D7794879419A91 8D775C824E5E4F01542F5951780C56686C148FC45F036C7D6CE38BAB63900000 C7 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000060706D3D72756266948E94C553438FC17B7E4EDF8C264E7E9ED494B194B3 524D6F5C90636D458C3458115D4C6B206B4967AA545B81547F8C589985375F3A 62A26A47953965726084686577A74E544FA85DE7979864AC7FD85CED4FCF7A8D 520783044E14602F7A8394A64FB54EB279E6743452E482B964D279BD5BDD6C81 97528F7B6C22503E537F6E0564CE66746C3060C598778BF75E86743C7A7779CB 4E1890B174036C4256DA914B6CC58D8B533A86C666F28EAF5C489A716E200000 C8 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000053D65A369F8B8DA353BB570898A76743919B6CC9516875CA62F372AC5238 529D7F3A7094763853749E4A69B7786E96C088D97FA4713671C3518967D374E4 58E4651856B78BA9997662707ED560F970ED58EC4EC14EBA5FCD97E74EFB8BA4 5203598A7EAB62544ECD65E5620E833884C98363878D71946EB65BB97ED25197 63C967D480898339881551125B7A59828FB14E736C5D516589258F6F962E854A 745E951095F06DA682E55F3164926D128428816E9CC3585E8D5B4E0953C10000 C9 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004F1E6563685155D34E2764149A9A626B5AC2745F82726DA968EE50E7838E 7802674052396C997EB150BB5565715E7B5B665273CA82EB67495C715220717D 886B95EA965564C58D6181B355846C5562477F2E58924F2455468D4F664C4E0A 5C1A88F368A2634E7A0D70E7828D52FA97F65C1154E890B57ECD59628D4A86C7 820C820D8D6664445C0461516D89793E8BBE78377533547B4F388EAB6DF15A20 7EC5795E6C885BA15A76751A80BE614E6E1758F0751F7525727253477EF30000 CA 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000770176DB526980DC57235E08593172EE65BD6E7F8BD75C388671534177F3 62FE65F64EC098DF86805B9E8BC653F277E24F7F5C4E9A7659CB5F0F793A58EB 4E1667FF4E8B62ED8A93901D52BF662F55DC566C90024ED54F8D91CA99706C0F 5E0260435BA489C68BD56536624B99965B885BFF6388552E53D77626517D852C 67A268B36B8A62928F9353D482126DD1758F4E668D4E5B70719F85AF669166D9 7F7287009ECD9F205C5E672F8FF06811675F620D7AD658855EB665706F310000 CB 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000060555237800D6454887075295E05681362F4971C53CC723D8C016C347761 7A0E542E77AC987A821C8BF47855671470C165AF64955636601D79C153F84E1D 6B7B80865BFA55E356DB4F3A4F3C99725DF3677E80386002988290015B8B8BBC 8BF5641C825864DE55FD82CF91654FD77D20901F7C9F50F358516EAF5BBF8BC9 80839178849C7B97867D968B968F7EE59AD3788E5C817A57904296A7795F5B59 635F7B0B84D168AD55067F2974107D2295016240584C4ED65B83597958540000 CC 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000736D631E8E4B8E0F80CE82D462AC53F06CF0915E592A60016C70574D644A 8D2A762B6EE9575B6A8075F06F6D8C2D8C0857666BEF889278B363A253F970AD 6C645858642A580268E0819B55107CD650188EBA6DCC8D9F70EB638F6D9B6ED4 7EE68404684390036DD896768BA85957727985E4817E75BC8A8A68AF52548E22 951163D098988E44557C4F5366FF568F60D56D9552435C4959296DFB586B7530 751C606C82148146631167618FE2773A8DF38D3494C15E165385542C70C30000 CD 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006C405EF7505C4EAD5EAD633A8247901A6850916E77B3540C94DC5F647AE5 687663457B527EDF75DB507762955934900F51F879C37A8156FE5F9290146D82 5C60571F541051546E4D56E263A89893817F8715892A9000541E5C6F81C062D6 625881319E3596409A6E9A7C692D59A562D3553E631654C786D96D3C5A0374E6 889C6B6A59168C4C5F2F6E7E73A9987D4E3870F75B8C7897633D665A769660CB 5B9B5A494E0781556C6A738B4EA167897F515F8065FA671B5FD859845A010000 CE 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005DCD5FAE537197E68FDD684556F4552F60DF4E3A6F4D7EF482C7840E59D4 4F1F4F2A5C3E7EAC672A851A5473754F80C355829B4F4F4D6E2D8C135C096170 536B761F6E29868A658795FB7EB9543B7A337D0A95EE55E17FC174EE631D8717 6DA17A9D621165A1536763E16C835DEB545C94A84E4C6C618BEC5C4B65E0829C 68A7543E54346BCB6B664E9463425348821E4F0D4FAE575E620A96FE66647269 52FF52A1609F8BEF661471996790897F785277FD6670563B54389521727A0000 CF 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00007A00606F5E0C6089819D591560DC718470EF6EAA6C5072806A8488AD5E2D 4E605AB3559C94E36D177CFB9699620F7EC6778E867E5323971E8F9666875CE1 4FA072ED4E0B53A6590F54136380952851484ED99C9C7EA454B88D2488548237 95F26D8E5F265ACC663E966973B0732E53BF817A99857FA15BAA967796507EBF 76F853A2957699997BB189446E584E617FD479658BE660F354CD4EAB98795DF7 6A6150CF54118C618427785D9704524A54EE56A395006D885BB56DC666530000 D0 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005C0F5B5D6821809655787B11654869544E9B6B47874E978B534F631F643A 90AA659C80C18C10519968B0537887F961C86CC46CFB8C225C5185AA82AF950C 6B238F9B65B05FFB5FC34FE18845661F8165732960FA51745211578B5F6290A2 884C91925E78674F602759D3514451F680F853086C7996C4718A4F114FEE7F9E 673D55C5950879C088967EE3589F620C9700865A5618987B5F908BB884C49157 53D965ED5E8F755C60647D6E5A7F7EEA7EED8F6955A75BA360AC65CB73840000 D1 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009009766377297EDA9774859B5B667A7496EA884052CB718F5FAA65EC8BE2 5BFB9A6F5DE16B896C5B8BAD8BAF900A8FC5538B62BC9E269E2D54404E2B82BD 7259869C5D1688596DAF96C554D14E9A8BB6710954BD960970DF6DF976D04E25 781487125CA95EF68A00989C960E708E6CBF594463A9773C884D6F1482735830 71D5538C781A96C155015F6671305BB48C1A9A8C6B83592E9E2F79E76768626C 4F6F75A17F8A6D0B96336C274EF075D2517B68376F3E90808170599674760000 D2 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000064475C2790657A918C2359DA54AC8200836F898180006930564E80367237 91CE51B64E5F987563964E1A53F666F3814B591C6DB24E0058F9533B63D694F1 4F9D4F0A886398905937905779FB4EEA80F075916C825B9C59E85F5D69058681 501A5DF24E5977E34EE5827A6291661390915C794EBF5F7981C69038808475AB 4EA688D4610F6BC55FC64E4976CA6EA28BE38BAE8C0A8BD15F027FFC7FCC7ECE 8335836B56E06BB797F3963459FB541F94F66DEB5BC5996E5C395F1596900000 D3 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000537082F16A315A749E705E947F2883B984248425836787478FCE8D6276C8 5F719896786C662054DF62E54F6381C375C85EB896CD8E0A86F9548F6CF36D8C 6C38607F52C775285E7D4F1860A05FE75C24753190AE94C072B96CB96E389149 670953CB53F34F5191C98BF153C85E7C8FC26DE44E8E76C26986865E611A8206 4F594FDE903E9C7C61096E1D6E1496854E885A3196E84E0E5C7F79B95B878BED 7FBD738957DF828B90C15401904755BB5CEA5FA161086B3272F180B28A890000 D4 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006D745BD388D598848C6B9A6D9E336E0A51A4514357A38881539F63F48F95 56ED54585706733F6E907F188FDC82D1613F6028966266F07EA68D8A8DC394A5 5CB37CA4670860A6960580184E9190E75300966851418FD08574915D665597F5 5B55531D78386742683D54C9707E5BB08F7D518D572854B1651266828D5E8D43 810F846C906D7CDF51FF85FB67A365E96FA186A48E81566A90207682707671E5 8D2362E952196CFD8D3C600E589E618E66FE8D60624E55B36E23672D8F670000 D5 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000094E195F87728680569A8548B4E4D70B88BC86458658B5B857A84503A5BE8 77BB6BE18A797C986CBE76CF65A98F975D2D5C5586386808536062187AD96E5B 7EFD6A1F7AE05F706F335F20638C6DA867564E085E108D264ED780C07634969C 62DB662D627E6CBC8D7571677F695146808753EC906E629854F286F08F998005 951785178FD96D5973CD659F771F7504782781FB8D1E94884FA6679575B98BCA 9707632F9547963584B8632377415F8172F04E896014657462EF6B63653F0000 D6 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005E2775C790D18BC1829D679D652F5431871877E580A281026C414E4B7EC7 804C76F4690D6B966267503C4F84574063076B628DBE53EA65E87EB85FD7631A 63B781F381F47F6E5E1C5CD95236667A79E97A1A8D28709975D46EDE6CBB7A92 4E2D76C55FE0949F88777EC879CD80BF91CD4EF24F17821F54685DDE6D328BCC 7CA58F7480985E1A549276B15B99663C9AA473E0682A86DB6731732A8BF88BDB 90107AF970DB716E62C477A956314E3B845767F152A986C08D2E94F87B510000 D7 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004F4F6CE8795D9A7B6293722A62FD4E1378168F6C64B08D5A7BC668695E84 88C55986649E58EE72B6690E95258FFD8D5857607F008C0651C6634962D95353 684C74228301914C55447740707C6D4A517954A88D4459FF6ECB6DC45B5C7D2B 4ED47C7D6ED35B5081EA6E0D5B579B0368D58E2A5B977EFC603B7EB590B98D70 594F63CD79DF8DB3535265CF79568BC5963B7EC494BB7E825634918967007F6A 5C0A907566285DE64F5067DE505A4F5C57505EA7000000000000000000000000 D8 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004E8D4E0C51404E105EFF53454E154E984E1E9B325B6C56694E2879BA4E3F 53154E47592D723B536E6C1056DF80E499976BD3777E9F174E364E9F9F104E5C 4E694E9382885B5B556C560F4EC4538D539D53A353A553AE97658D5D531A53F5 5326532E533E8D5C5366536352025208520E522D5233523F5240524C525E5261 525C84AF527D528252815290529351827F544EBB4EC34EC94EC24EE84EE14EEB 4EDE4F1B4EF34F224F644EF54F254F274F094F2B4F5E4F6765384F5A4F5D0000 D9 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00004F5F4F574F324F3D4F764F744F914F894F834F8F4F7E4F7B4FAA4F7C4FAC 4F944FE64FE84FEA4FC54FDA4FE34FDC4FD14FDF4FF85029504C4FF3502C500F 502E502D4FFE501C500C50255028507E504350555048504E506C507B50A550A7 50A950BA50D6510650ED50EC50E650EE5107510B4EDD6C3D4F584F654FCE9FA0 6C467C74516E5DFD9EC999985181591452F9530D8A07531051EB591951554EA0 51564EB3886E88A44EB5811488D279805B3488037FB851AB51B151BD51BC0000 DA 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000051C7519651A251A58BA08BA68BA78BAA8BB48BB58BB78BC28BC38BCB8BCF 8BCE8BD28BD38BD48BD68BD88BD98BDC8BDF8BE08BE48BE88BE98BEE8BF08BF3 8BF68BF98BFC8BFF8C008C028C048C078C0C8C0F8C118C128C148C158C168C19 8C1B8C188C1D8C1F8C208C218C258C278C2A8C2B8C2E8C2F8C328C338C358C36 5369537A961D962296219631962A963D963C964296499654965F9667966C9672 96749688968D969796B09097909B909D909990AC90A190B490B390B690BA0000 DB 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000090B890B090CF90C590BE90D090C490C790D390E690E290DC90D790DB90EB 90EF90FE91049122911E91239131912F913991439146520D594252A252AC52AD 52BE54FF52D052D652F053DF71EE77CD5EF451F551FC9B2F53B65F01755A5DEF 574C57A957A1587E58BC58C558D15729572C572A57335739572E572F575C573B 574257695785576B5786577C577B5768576D5776577357AD57A4578C57B257CF 57A757B4579357A057D557D857DA57D957D257B857F457EF57F857E457DD0000 DC 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000580B580D57FD57ED5800581E5819584458205865586C58815889589A5880 99A89F1961FF8279827D827F828F828A82A88284828E82918297829982AB82B8 82BE82B082C882CA82E3829882B782AE82CB82CC82C182A982B482A182AA829F 82C482CE82A482E1830982F782E4830F830782DC82F482D282D8830C82FB82D3 8311831A83068314831582E082D5831C8351835B835C83088392833C83348331 839B835E832F834F83478343835F834083178360832D833A8333836683650000 DD 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008368831B8369836C836A836D836E83B0837883B383B483A083AA8393839C 8385837C83B683A9837D83B8837B8398839E83A883BA83BC83C1840183E583D8 58078418840B83DD83FD83D6841C84388411840683D483DF840F840383F883F9 83EA83C583C0842683F083E1845C8451845A8459847384878488847A84898478 843C844684698476848C848E8431846D84C184CD84D084E684BD84D384CA84BF 84BA84E084A184B984B4849784E584E3850C750D853884F08539851F853A0000 DE 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008556853B84FF84FC8559854885688564855E857A77A285438572857B85A4 85A88587858F857985AE859C858585B985B785B085D385C185DC85FF86278605 86298616863C5EFE5F08593C594180375955595A5958530F5C225C255C2C5C34 624C626A629F62BB62CA62DA62D762EE632262F66339634B634363AD63F66371 637A638E63B4636D63AC638A636963AE63BC63F263F863E063FF63C463DE63CE 645263C663BE64456441640B641B6420640C64266421645E6484646D64960000 DF 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000647A64B764B8649964BA64C064D064D764E464E265096525652E5F0B5FD2 75195F11535F53F153FD53E953E853FB541254165406544B5452545354545456 54435421545754595423543254825494547754715464549A549B548454765466 549D54D054AD54C254B454D254A754A654D354D4547254A354D554BB54BF54CC 54D954DA54DC54A954AA54A454DD54CF54DE551B54E7552054FD551454F35522 5523550F55115527552A5567558F55B55549556D55415555553F5550553C0000 E0 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005537555655755576557755335530555C558B55D2558355B155B955885581 559F557E55D65591557B55DF55BD55BE5594559955EA55F755C9561F55D155EB 55EC55D455E655DD55C455EF55E555F255F355CC55CD55E855F555E48F94561E 5608560C56015624562355FE56005627562D565856395657562C564D56625659 565C564C5654568656645671566B567B567C5685569356AF56D456D756DD56E1 56F556EB56F956FF5704570A5709571C5E0F5E195E145E115E315E3B5E3C0000 E1 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00005E375E445E545E5B5E5E5E615C8C5C7A5C8D5C905C965C885C985C995C91 5C9A5C9C5CB55CA25CBD5CAC5CAB5CB15CA35CC15CB75CC45CD25CE45CCB5CE5 5D025D035D275D265D2E5D245D1E5D065D1B5D585D3E5D345D3D5D6C5D5B5D6F 5D5D5D6B5D4B5D4A5D695D745D825D995D9D8C735DB75DC55F735F775F825F87 5F895F8C5F955F995F9C5FA85FAD5FB55FBC88625F6172AD72B072B472B772B8 72C372C172CE72CD72D272E872EF72E972F272F472F7730172F3730372FA0000 E2 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000072FB731773137321730A731E731D7315732273397325732C733873317350 734D73577360736C736F737E821B592598E7592459029963996799689969996A 996B996C99749977997D998099849987998A998D999099919993999499955E80 5E915E8B5E965EA55EA05EB95EB55EBE5EB38D535ED25ED15EDB5EE85EEA81BA 5FC45FC95FD65FCF60035FEE60045FE15FE45FFE600560065FEA5FED5FF86019 60356026601B600F600D6029602B600A603F602160786079607B607A60420000 E3 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000606A607D6096609A60AD609D60836092608C609B60EC60BB60B160DD60D8 60C660DA60B4612061266115612360F46100610E612B614A617561AC619461A7 61B761D461F55FDD96B395E995EB95F195F395F595F695FC95FE960396049606 9608960A960B960C960D960F96129615961696179619961A4E2C723F62156C35 6C546C5C6C4A6CA36C856C906C946C8C6C686C696C746C766C866CA96CD06CD4 6CAD6CF76CF86CF16CD76CB26CE06CD66CFA6CEB6CEE6CB16CD36CEF6CFE0000 E4 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006D396D276D0C6D436D486D076D046D196D0E6D2B6D4D6D2E6D356D1A6D4F 6D526D546D336D916D6F6D9E6DA06D5E6D936D946D5C6D606D7C6D636E1A6DC7 6DC56DDE6E0E6DBF6DE06E116DE66DDD6DD96E166DAB6E0C6DAE6E2B6E6E6E4E 6E6B6EB26E5F6E866E536E546E326E256E446EDF6EB16E986EE06F2D6EE26EA5 6EA76EBD6EBB6EB76ED76EB46ECF6E8F6EC26E9F6F626F466F476F246F156EF9 6F2F6F366F4B6F746F2A6F096F296F896F8D6F8C6F786F726F7C6F7A6FD10000 E5 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00006FC96FA76FB96FB66FC26FE16FEE6FDE6FE06FEF701A7023701B70397035 704F705E5B805B845B955B935BA55BB8752F9A9E64345BE45BEE89305BF08E47 8B078FB68FD38FD58FE58FEE8FE48FE98FE68FF38FE890059004900B90269011 900D9016902190359036902D902F9044905190529050906890589062905B66B9 9074907D908290889083908B5F505F575F565F585C3B54AB5C505C595B715C63 5C667FBC5F2A5F295F2D82745F3C9B3B5C6E59815983598D59A959AA59A30000 E6 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000599759CA59AB599E59A459D259B259AF59D759BE5A055A0659DD5A0859E3 59D859F95A0C5A095A325A345A115A235A135A405A675A4A5A555A3C5A625A75 80EC5AAA5A9B5A775A7A5ABE5AEB5AB25AD25AD45AB85AE05AE35AF15AD65AE6 5AD85ADC5B095B175B165B325B375B405C155C1C5B5A5B655B735B515B535B62 9A759A779A789A7A9A7F9A7D9A809A819A859A889A8A9A909A929A939A969A98 9A9B9A9C9A9D9A9F9AA09AA29AA39AA59AA77E9F7EA17EA37EA57EA87EA90000 E7 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00007EAD7EB07EBE7EC07EC17EC27EC97ECB7ECC7ED07ED47ED77EDB7EE07EE1 7EE87EEB7EEE7EEF7EF17EF27F0D7EF67EFA7EFB7EFE7F017F027F037F077F08 7F0B7F0C7F0F7F117F127F177F197F1C7F1B7F1F7F217F227F237F247F257F26 7F277F2A7F2B7F2C7F2D7F2F7F307F317F327F337F355E7A757F5DDB753E9095 738E739173AE73A2739F73CF73C273D173B773B373C073C973C873E573D9987C 740A73E973E773DE73BA73F2740F742A745B7426742574287430742E742C0000 E8 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000741B741A7441745C7457745574597477746D747E749C748E748074817487 748B749E74A874A9749074A774D274BA97EA97EB97EC674C6753675E67486769 67A56787676A6773679867A7677567A8679E67AD678B6777677C67F0680967D8 680A67E967B0680C67D967B567DA67B367DD680067C367B867E2680E67C167FD 6832683368606861684E6862684468646883681D68556866684168676840683E 684A6849682968B5688F687468776893686B68C2696E68FC691F692068F90000 E9 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000692468F0690B6901695768E369106971693969606942695D6984696B6980 69986978693469CC6987698869CE6989696669636979699B69A769BB69AB69AD 69D469B169C169CA69DF699569E0698D69FF6A2F69ED6A176A186A6569F26A44 6A3E6AA06A506A5B6A356A8E6A796A3D6A286A586A7C6A916A906AA96A976AAB 733773526B816B826B876B846B926B936B8D6B9A6B9B6BA16BAA8F6B8F6D8F71 8F728F738F758F768F788F778F798F7A8F7C8F7E8F818F828F848F878F8B0000 EA 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00008F8D8F8E8F8F8F988F9A8ECE620B6217621B621F6222622162256224622C 81E774EF74F474FF750F75117513653465EE65EF65F0660A6619677266036615 6600708566F7661D66346631663666358006665F66546641664F665666616657 66776684668C66A7669D66BE66DB66DC66E666E98D328D338D368D3B8D3D8D40 8D458D468D488D498D478D4D8D558D5989C789CA89CB89CC89CE89CF89D089D1 726E729F725D7266726F727E727F7284728B728D728F72926308633263B00000 EB 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000643F64D880046BEA6BF36BFD6BF56BF96C056C076C066C0D6C156C186C19 6C1A6C216C296C246C2A6C3265356555656B724D72527256723086625216809F 809C809380BC670A80BD80B180AB80AD80B480B780E780E880E980EA80DB80C2 80C480D980CD80D7671080DD80EB80F180F480ED810D810E80F280FC67158112 8C5A8136811E812C811881328148814C815381748159815A817181608169817C 817D816D8167584D5AB58188818281916ED581A381AA81CC672681CA81BB0000 EC 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000081C181A66B246B376B396B436B466B5998D198D298D398D598D998DA6BB3 5F406BC289F365909F51659365BC65C665C465C365CC65CE65D265D67080709C 7096709D70BB70C070B770AB70B170E870CA711071137116712F71317173715C 716871457172714A7178717A719871B371B571A871A071E071D471E771F9721D 7228706C7118716671B9623E623D624362486249793B794079467949795B795C 7953795A796279577960796F7967797A7985798A799A79A779B35FD15FD00000 ED 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000603C605D605A606760416059606360AB6106610D615D61A9619D61CB61D1 62068080807F6C936CF66DFC77F677F87800780978177818781165AB782D781C 781D7839783A783B781F783C7825782C78237829784E786D7856785778267850 7847784C786A789B7893789A7887789C78A178A378B278B978A578D478D978C9 78EC78F2790578F479137924791E79349F9B9EF99EFB9EFC76F17704770D76F9 77077708771A77227719772D7726773577387750775177477743775A77680000 EE 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000077627765777F778D777D7780778C7791779F77A077B077B577BD753A7540 754E754B7548755B7572757975837F587F617F5F8A487F687F747F717F797F81 7F7E76CD76E58832948594869487948B948A948C948D948F9490949494979495 949A949B949C94A394A494AB94AA94AD94AC94AF94B094B294B494B694B794B8 94B994BA94BC94BD94BF94C494C894C994CA94CB94CC94CD94CE94D094D194D2 94D594D694D794D994D894DB94DE94DF94E094E294E494E594E794E894EA0000 EF 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000094E994EB94EE94EF94F394F494F594F794F994FC94FD94FF950395029506 95079509950A950D950E950F951295139514951595169518951B951D951E951F 9522952A952B9529952C953195329534953695379538953C953E953F95429535 9544954595469549954C954E954F9552955395549556955795589559955B955E 955F955D95619562956495659566956795689569956A956B956C956F95719572 9573953A77E777EC96C979D579ED79E379EB7A065D477A037A027A1E7A140000 F0 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00007A397A377A519ECF99A57A707688768E7693769976A474DE74E0752C9E20 9E229E289E299E2A9E2B9E2C9E329E319E369E389E379E399E3A9E3E9E419E42 9E449E469E479E489E499E4B9E4C9E4E9E519E559E579E5A9E5B9E5C9E5E9E63 9E669E679E689E699E6A9E6B9E6C9E719E6D9E7375927594759675A0759D75AC 75A375B375B475B875C475B175B075C375C275D675CD75E375E875E675E475EB 75E7760375F175FC75FF761076007605760C7617760A76257618761576190000 F1 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000761B763C762276207640762D7630763F76357643763E7633764D765E7654 765C7656766B766F7FCA7AE67A787A797A807A867A887A957AA67AA07AAC7AA8 7AAD7AB3886488698872887D887F888288A288C688B788BC88C988E288CE88E3 88E588F1891A88FC88E888FE88F0892189198913891B890A8934892B89368941 8966897B758B80E576B276B477DC801280148016801C80208022802580268027 802980288031800B803580438046804D80528069807189839878988098830000 F2 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009889988C988D988F9894989A989B989E989F98A198A298A598A6864D8654 866C866E867F867A867C867B86A8868D868B86AC869D86A786A386AA869386A9 86B686C486B586CE86B086BA86B186AF86C986CF86B486E986F186F286ED86F3 86D0871386DE86F486DF86D886D18703870786F88708870A870D87098723873B 871E8725872E871A873E87488734873187298737873F87828722877D877E877B 87608770874C876E878B87538763877C876487598765879387AF87A887D20000 F3 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000087C68788878587AD8797878387AB87E587AC87B587B387CB87D387BD87D1 87C087CA87DB87EA87E087EE8816881387FE880A881B88218839883C7F367F42 7F447F4582107AFA7AFD7B087B037B047B157B0A7B2B7B0F7B477B387B2A7B19 7B2E7B317B207B257B247B337B3E7B1E7B587B5A7B457B757B4C7B5D7B607B6E 7B7B7B627B727B717B907BA67BA77BB87BAC7B9D7BA87B857BAA7B9C7BA27BAB 7BB47BD17BC17BCC7BDD7BDA7BE57BE67BEA7C0C7BFE7BFC7C0F7C167C0B0000 F4 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00007C1F7C2A7C267C387C417C4081FE82018202820481EC8844822182228223 822D822F8228822B8238823B82338234823E82448249824B824F825A825F8268 887E8885888888D888DF895E7F9D7F9F7FA77FAF7FB07FB27C7C65497C917C9D 7C9C7C9E7CA27CB27CBC7CBD7CC17CC77CCC7CCD7CC87CC57CD77CE8826E66A8 7FBF7FCE7FD57FE57FE17FE67FE97FEE7FF37CF87D777DA67DAE7E477E9B9EB8 9EB48D738D848D948D918DB18D678D6D8C478C49914A9150914E914F91640000 F5 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009162916191709169916F917D917E917291749179918C91859190918D9191 91A291A391AA91AD91AE91AF91B591B491BA8C559E7E8DB88DEB8E058E598E69 8DB58DBF8DBC8DBA8DC48DD68DD78DDA8DDE8DCE8DCF8DDB8DC68DEC8DF78DF8 8DE38DF98DFB8DE48E098DFD8E148E1D8E1F8E2C8E2E8E238E2F8E3A8E408E39 8E358E3D8E318E498E418E428E518E528E4A8E708E768E7C8E6F8E748E858E8F 8E948E908E9C8E9E8C788C828C8A8C858C988C94659B89D689DE89DA89DC0000 F6 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 000089E589EB89EF8A3E8B26975396E996F396EF970697019708970F970E972A 972D9730973E9F809F839F859F869F879F889F899F8A9F8C9EFE9F0B9F0D96B9 96BC96BD96CE96D277BF96E0928E92AE92C8933E936A93CA938F943E946B9C7F 9C829C859C869C879C887A239C8B9C8E9C909C919C929C949C959C9A9C9B9C9E 9C9F9CA09CA19CA29CA39CA59CA69CA79CA89CA99CAB9CAD9CAE9CB09CB19CB2 9CB39CB49CB59CB69CB79CBA9CBB9CBC9CBD9CC49CC59CC69CC79CCA9CCB0000 F7 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 0000000000000000000000000000000000000000000000000000000000000000 00009CCC9CCD9CCE9CCF9CD09CD39CD49CD59CD79CD89CD99CDC9CDD9CDF9CE2 977C978597919792979497AF97AB97A397B297B49AB19AB09AB79E589AB69ABA 9ABC9AC19AC09AC59AC29ACB9ACC9AD19B459B439B479B499B489B4D9B5198E8 990D992E995599549ADF9AE19AE69AEF9AEB9AFB9AED9AF99B089B0F9B139B1F 9B239EBD9EBE7E3B9E829E879E889E8B9E9293D69E9D9E9F9EDB9EDC9EDD9EE0 9EDF9EE29EE99EE79EE59EEA9EEF9F229F2C9F2F9F399F379F3D9F3E9F440000 |
Changes to library/history.tcl.
1 2 3 4 | # history.tcl -- # # Implementation of the history command. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # history.tcl -- # # Implementation of the history command. # # RCS: @(#) $Id: history.tcl,v 1.5.14.1 2005/07/22 21:59:40 dgp Exp $ # # Copyright (c) 1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # |
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
# Side Effects:
# Adds to the history list
proc tcl::HistAdd {command {exec {}}} {
variable history
# Do not add empty commands to the history
| | | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
# Side Effects:
# Adds to the history list
proc tcl::HistAdd {command {exec {}}} {
variable history
# Do not add empty commands to the history
if {[string trim $command] eq ""} {
return ""
}
set i [incr history(nextid)]
set history($i) $command
set j [incr history(oldest)]
unset -nocomplain history($j)
if {[string match e* $exec]} {
return [uplevel #0 $command]
} else {
return {}
}
}
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
# If no limit is specified, the current limit is returned
#
# Side Effects:
# Updates history(keep) if a limit is specified
proc tcl::HistKeep {{limit {}}} {
variable history
| | | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
# If no limit is specified, the current limit is returned
#
# Side Effects:
# Updates history(keep) if a limit is specified
proc tcl::HistKeep {{limit {}}} {
variable history
if {$limit eq ""} {
return $history(keep)
} else {
set oldold $history(oldest)
set history(oldest) [expr {$history(nextid) - $limit}]
for {} {$oldold <= $history(oldest)} {incr oldold} {
unset -nocomplain history($oldold)
}
set history(keep) $limit
}
}
# tcl::HistClear --
#
|
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
# num (optional) the length of the history list to return
#
# Results:
# A formatted history list
proc tcl::HistInfo {{num {}}} {
variable history
| | | < | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 |
# num (optional) the length of the history list to return
#
# Results:
# A formatted history list
proc tcl::HistInfo {{num {}}} {
variable history
if {$num eq ""} {
set num [expr {$history(keep) + 1}]
}
set result {}
set newline ""
for {set i [expr {$history(nextid) - $num + 1}]} \
{$i <= $history(nextid)} {incr i} {
if {![info exists history($i)]} {
continue
}
set cmd [string map [list \n \n\t] [string trimright $history($i) \ \n]]
append result $newline[format "%6d %s" $i $cmd]
set newline \n
}
return $result
}
# tcl::HistRedo --
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
# Those of the command being redone.
#
# Side Effects:
# Replaces the current history list item with the one being redone.
proc tcl::HistRedo {{event -1}} {
variable history
| | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
# Those of the command being redone.
#
# Side Effects:
# Replaces the current history list item with the one being redone.
proc tcl::HistRedo {{event -1}} {
variable history
if {$event eq ""} {
set event -1
}
set i [HistIndex $event]
if {$i == $history(nextid)} {
return -code error "cannot redo the current event"
}
set cmd $history($i)
|
| ︙ | ︙ |
Changes to library/http/http.tcl.
1 2 | # http.tcl -- # | | | < | | | | | | | | | | | | | | | | | > | | > > > | | > | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
# http.tcl --
#
# Client-side HTTP for GET, POST, and HEAD commands. These routines can
# be used in untrusted code that uses the Safesock security policy. These
# procedures use a callback interface to avoid using vwait, which is not
# defined in the safe base.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: http.tcl,v 1.43.2.13 2006/10/06 05:56:48 hobbs Exp $
# Rough version history:
# 1.0 Old http_get interface.
# 2.0 http:: namespace and http::geturl.
# 2.1 Added callbacks to handle arriving data, and timeouts.
# 2.2 Added ability to fetch into a channel.
# 2.3 Added SSL support, and ability to post from a channel. This version
# also cleans up error cases and eliminates the "ioerror" status in
# favor of raising an error
# 2.4 Added -binary option to http::geturl and charset element to the state
# array.
package require Tcl 8.4
# Keep this in sync with pkgIndex.tcl and with the install directories
# in Makefiles
package provide http 2.5.3
namespace eval http {
variable http
array set http {
-accept */*
-proxyhost {}
-proxyport {}
-proxyfilter http::ProxyRequired
-urlencoding utf-8
}
set http(-useragent) "Tcl http client package [package provide http]"
proc init {} {
# Set up the map for quoting chars. RFC3986 Section 2.3 say percent
# encode all except: "... percent-encoded octets in the ranges of ALPHA
# (%41-%5A and %61-%7A), DIGIT (%30-%39), hyphen (%2D), period (%2E),
# underscore (%5F), or tilde (%7E) should not be created by URI
# producers ..."
for {set i 0} {$i <= 256} {incr i} {
set c [format %c $i]
if {![string match {[-._~a-zA-Z0-9]} $c]} {
set map($c) %[format %.2x $i]
}
}
# These are handled specially
set map(\n) %0d%0a
variable formMap [array get map]
}
init
variable urlTypes
array set urlTypes {
http {80 ::socket}
}
variable encodings [string tolower [encoding names]]
# This can be changed, but iso8859-1 is the RFC standard.
variable defaultCharset "iso8859-1"
# Force RFC 3986 strictness in geturl url verification? Not for 8.4.x
variable strict 0
namespace export geturl config reset wait formatQuery register unregister
# Useful, but not exported: data size status code
}
# http::register --
#
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
if {[llength $args] == 0} {
set result {}
foreach name $options {
lappend result $name $http($name)
}
return $result
}
| | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 |
if {[llength $args] == 0} {
set result {}
foreach name $options {
lappend result $name $http($name)
}
return $result
}
set options [string map {- ""} $options]
set pat ^-([join $options |])$
if {[llength $args] == 1} {
set flag [lindex $args 0]
if {[regexp -- $pat $flag]} {
return $http($flag)
} else {
return -code error "Unknown option $flag, must be: $usage"
|
| ︙ | ︙ | |||
142 143 144 145 146 147 148 | # http::Finish -- # # Clean up the socket and eval close time callbacks # # Arguments: # token Connection token. # errormsg (optional) If set, forces status to error. | | | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
# http::Finish --
#
# Clean up the socket and eval close time callbacks
#
# Arguments:
# token Connection token.
# errormsg (optional) If set, forces status to error.
# skipCB (optional) If set, don't call the -command callback. This
# is useful when geturl wants to throw an exception instead
# of calling the callback. That way, the same error isn't
# reported to two places.
#
# Side Effects:
# Closes the socket
proc http::Finish { token {errormsg ""} {skipCB 0}} {
variable $token
|
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | # Establishes a connection to a remote url via http. # # Arguments: # url The http URL to goget. # args Option value pairs. Valid options include: # -blocksize, -validate, -headers, -timeout # Results: | | < | > | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
# Establishes a connection to a remote url via http.
#
# Arguments:
# url The http URL to goget.
# args Option value pairs. Valid options include:
# -blocksize, -validate, -headers, -timeout
# Results:
# Returns a token for this connection. This token is the name of an array
# that the caller should unset to garbage collect the state.
proc http::geturl { url args } {
variable http
variable urlTypes
variable defaultCharset
variable strict
# Initialize the state variable, an array. We'll return the name of this
# array as the token for the transaction.
if {![info exists http(uid)]} {
set http(uid) 0
}
set token [namespace current]::[incr http(uid)]
variable $token
upvar 0 $token state
|
| ︙ | ︙ | |||
250 251 252 253 254 255 256 257 258 259 260 261 262 |
totalsize 0
querylength 0
queryoffset 0
type text/html
body {}
status ""
http ""
}
set state(charset) $defaultCharset
set options {-binary -blocksize -channel -command -handler -headers \
-progress -query -queryblocksize -querychannel -queryprogress\
-validate -timeout -type}
set usage [join $options ", "]
| > > > > > > > > | | < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < > > > > > > > > > > > > > > | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | < | | | | | | | | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
totalsize 0
querylength 0
queryoffset 0
type text/html
body {}
status ""
http ""
}
# These flags have their types verified [Bug 811170]
array set type {
-binary boolean
-blocksize integer
-queryblocksize integer
-validate boolean
-timeout integer
}
set state(charset) $defaultCharset
set options {-binary -blocksize -channel -command -handler -headers \
-progress -query -queryblocksize -querychannel -queryprogress\
-validate -timeout -type}
set usage [join $options ", "]
set options [string map {- ""} $options]
set pat ^-([join $options |])$
foreach {flag value} $args {
if {[regexp $pat $flag]} {
# Validate numbers
if {[info exists type($flag)] && \
![string is $type($flag) -strict $value]} {
unset $token
return -code error "Bad value for $flag ($value), must be $type($flag)"
}
set state($flag) $value
} else {
unset $token
return -code error "Unknown option $flag, can be: $usage"
}
}
# Make sure -query and -querychannel aren't both specified
set isQueryChannel [info exists state(-querychannel)]
set isQuery [info exists state(-query)]
if {$isQuery && $isQueryChannel} {
unset $token
return -code error "Can't combine -query and -querychannel options!"
}
# Validate URL, determine the server host and port, and check proxy case
# Recognize user:pass@host URLs also, although we do not do anything with
# that info yet.
# URLs have basically four parts.
# First, before the colon, is the protocol scheme (e.g. http)
# Second, for HTTP-like protocols, is the authority
# The authority is preceded by // and lasts up to (but not including)
# the following / and it identifies up to four parts, of which only one,
# the host, is required (if an authority is present at all). All other
# parts of the authority (user name, password, port number) are optional.
# Third is the resource name, which is split into two parts at a ?
# The first part (from the single "/" up to "?") is the path, and the
# second part (from that "?" up to "#") is the query. *HOWEVER*, we do
# not need to separate them; we send the whole lot to the server.
# Fourth is the fragment identifier, which is everything after the first
# "#" in the URL. The fragment identifier MUST NOT be sent to the server
# and indeed, we don't bother to validate it (it could be an error to
# pass it in here, but it's cheap to strip).
#
# An example of a URL that has all the parts:
# http://jschmoe:xyzzy@www.bogus.net:8000/foo/bar.tml?q=foo#changes
# The "http" is the protocol, the user is "jschmoe", the password is
# "xyzzy", the host is "www.bogus.net", the port is "8000", the path is
# "/foo/bar.tml", the query is "q=foo", and the fragment is "changes".
#
# Note that the RE actually combines the user and password parts, as
# recommended in RFC 3986. Indeed, that RFC states that putting passwords
# in URLs is a Really Bad Idea, something with which I would agree utterly.
# Also note that we do not currently support IPv6 addresses.
#
# From a validation perspective, we need to ensure that the parts of the
# URL that are going to the server are correctly encoded.
# This is only done if $::http::strict is true (default 0 for compat).
set URLmatcher {(?x) # this is _expanded_ syntax
^
(?: (\w+) : ) ? # <protocol scheme>
(?: //
(?:
(
[^@/\#?]+ # <userinfo part of authority>
) @
)?
( [^/:\#?]+ ) # <host part of authority>
(?: : (\d+) )? # <port part of authority>
)?
( / [^\#?]* (?: \? [^\#?]* )?)? # <path> (including query)
(?: \# (.*) )? # <fragment>
$
}
# Phase one: parse
if {![regexp -- $URLmatcher $url -> proto user host port srvurl]} {
unset $token
return -code error "Unsupported URL: $url"
}
# Phase two: validate
if {$host eq ""} {
# Caller has to provide a host name; we do not have a "default host"
# that would enable us to handle relative URLs.
unset $token
return -code error "Missing host part: $url"
# Note that we don't check the hostname for validity here; if it's
# invalid, we'll simply fail to resolve it later on.
}
if {$port ne "" && $port>65535} {
unset $token
return -code error "Invalid port number: $port"
}
# The user identification and resource identification parts of the URL can
# have encoded characters in them; take care!
if {$user ne ""} {
# Check for validity according to RFC 3986, Appendix A
set validityRE {(?xi)
^
(?: [-\w.~!$&'()*+,;=:] | %[0-9a-f][0-9a-f] )+
$
}
if {$strict && ![regexp -- $validityRE $user]} {
unset $token
# Provide a better error message in this error case
if {[regexp {(?i)%(?![0-9a-f][0-9a-f]).?.?} $user bad]} {
return -code error \
"Illegal encoding character usage \"$bad\" in URL user"
}
return -code error "Illegal characters in URL user"
}
}
if {$srvurl ne ""} {
# Check for validity according to RFC 3986, Appendix A
set validityRE {(?xi)
^
# Path part (already must start with / character)
(?: [-\w.~!$&'()*+,;=:@/] | %[0-9a-f][0-9a-f] )*
# Query part (optional, permits ? characters)
(?: \? (?: [-\w.~!$&'()*+,;=:@/?] | %[0-9a-f][0-9a-f] )* )?
$
}
if {$strict && ![regexp -- $validityRE $srvurl]} {
unset $token
# Provide a better error message in this error case
if {[regexp {(?i)%(?![0-9a-f][0-9a-f])..} $srvurl bad]} {
return -code error \
"Illegal encoding character usage \"$bad\" in URL path"
}
return -code error "Illegal characters in URL path"
}
} else {
set srvurl /
}
if {[string length $proto] == 0} {
set proto http
}
if {![info exists urlTypes($proto)]} {
unset $token
return -code error "Unsupported URL type \"$proto\""
}
set defport [lindex $urlTypes($proto) 0]
set defcmd [lindex $urlTypes($proto) 1]
if {[string length $port] == 0} {
set port $defport
}
if {![catch {$http(-proxyfilter) $host} proxy]} {
set phost [lindex $proxy 0]
set pport [lindex $proxy 1]
}
# OK, now reassemble into a full URL
set url ${proto}://
if {$user ne ""} {
append url $user
append url @
}
append url $host
if {$port != $defport} {
append url : $port
}
append url $srvurl
# Don't append the fragment!
set state(url) $url
# If a timeout is specified we set up the after event and arrange for an
# asynchronous socket connection.
if {$state(-timeout) > 0} {
set state(after) [after $state(-timeout) \
[list http::reset $token timeout]]
set async -async
} else {
set async ""
}
# If we are using the proxy, we must pass in the full URL that includes
# the server name.
if {[info exists phost] && [string length $phost]} {
set srvurl $url
set conStat [catch {eval $defcmd $async {$phost $pport}} s]
} else {
set conStat [catch {eval $defcmd $async {$host $port}} s]
}
if {$conStat} {
# Something went wrong while trying to establish the connection. Clean
# up after events and such, but DON'T call the command callback (if
# available) because we're going to throw an exception from here
# instead.
Finish $token "" 1
cleanup $token
return -code error $s
}
set state(sock) $s
# Wait for the connection to complete.
if {$state(-timeout) > 0} {
fileevent $s writable [list http::Connect $token]
http::wait $token
if {$state(status) eq "error"} {
# Something went wrong while trying to establish the connection.
# Clean up after events and such, but DON'T call the command
# callback (if available) because we're going to throw an
# exception from here instead.
set err [lindex $state(error) 0]
cleanup $token
return -code error $err
} elseif {$state(status) ne "connect"} {
# Likely to be connection timeout
return $token
}
set state(status) ""
}
# Send data in cr-lf format, but accept any line terminators
fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
# The following is disallowed in safe interpreters, but the socket is
# already in non-blocking mode in that case.
catch {fconfigure $s -blocking off}
set how GET
if {$isQuery} {
set state(querylength) [string length $state(-query)]
if {$state(querylength) > 0} {
set how POST
set contDone 0
} else {
# There's no query data.
unset state(-query)
set isQuery 0
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
fconfigure $state(-querychannel) -blocking 1 -translation binary
set contDone 0
}
if {[catch {
puts $s "$how $srvurl HTTP/1.0"
puts $s "Accept: $http(-accept)"
if {$port == $defport} {
# Don't add port in this case, to handle broken servers. [Bug
# 504508]
puts $s "Host: $host"
} else {
puts $s "Host: $host:$port"
}
puts $s "User-Agent: $http(-useragent)"
foreach {key value} $state(-headers) {
set value [string map [list \n "" \r ""] $value]
set key [string trim $key]
if {$key eq "Content-Length"} {
set contDone 1
set state(querylength) $value
}
if {[string length $key]} {
puts $s "$key: $value"
}
}
if {$isQueryChannel && $state(querylength) == 0} {
# Try to determine size of data in channel. If we cannot seek, the
# surrounding catch will trap us
set start [tell $state(-querychannel)]
seek $state(-querychannel) 0 end
set state(querylength) \
[expr {[tell $state(-querychannel)] - $start}]
seek $state(-querychannel) $start
}
# Flush the request header and set up the fileevent that will either
# push the POST data or read the response.
#
# fileevent note:
#
# It is possible to have both the read and write fileevents active at
# this point. The only scenario it seems to affect is a server that
# closes the connection without reading the POST data. (e.g., early
# versions TclHttpd in various error cases). Depending on the platform,
# the client may or may not be able to get the response from the server
# because of the error it will get trying to write the post data.
# Having both fileevents active changes the timing and the behavior,
# but no two platforms (among Solaris, Linux, and NT) behave the same,
# and none behave all that well in any case. Servers should always read
# their POST data if they expect the client to read their response.
if {$isQuery || $isQueryChannel} {
puts $s "Content-Type: $state(-type)"
if {!$contDone} {
puts $s "Content-Length: $state(querylength)"
}
puts $s ""
fconfigure $s -translation {auto binary}
fileevent $s writable [list http::Write $token]
} else {
puts $s ""
flush $s
fileevent $s readable [list http::Event $token]
}
if {! [info exists state(-command)]} {
# geturl does EVERYTHING asynchronously, so if the user calls it
# synchronously, we just do a wait here.
wait $token
if {$state(status) eq "error"} {
# Something went wrong, so throw the exception, and the
# enclosing catch will do cleanup.
return -code error [lindex $state(error) 0]
}
}
} err]} {
# The socket probably was never connected, or the connection dropped
# later.
# Clean up after events and such, but DON'T call the command callback
# (if available) because we're going to throw an exception from here
# instead.
# if state(status) is error, it means someone's already called Finish
# to do the above-described clean up.
if {$state(status) eq "error"} {
Finish $token $err 1
}
cleanup $token
return -code error $err
}
return $token
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 |
# Side Effects
# Write the socket and handle callbacks.
proc http::Write {token} {
variable $token
upvar 0 $token state
set s $state(sock)
| | < < < | | < | | | | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
# Side Effects
# Write the socket and handle callbacks.
proc http::Write {token} {
variable $token
upvar 0 $token state
set s $state(sock)
# Output a block. Tcl will buffer this if the socket blocks
set done 0
if {[catch {
# Catch I/O errors on dead sockets
if {[info exists state(-query)]} {
# Chop up large query strings so queryprogress callback can give
# smooth feedback.
puts -nonewline $s \
[string range $state(-query) $state(queryoffset) \
[expr {$state(queryoffset) + $state(-queryblocksize) - 1}]]
incr state(queryoffset) $state(-queryblocksize)
if {$state(queryoffset) >= $state(querylength)} {
set state(queryoffset) $state(querylength)
set done 1
}
} else {
# Copy blocks from the query channel
set outStr [read $state(-querychannel) $state(-queryblocksize)]
puts -nonewline $s $outStr
incr state(queryoffset) [string length $outStr]
if {[eof $state(-querychannel)]} {
set done 1
}
}
} err]} {
# Do not call Finish here, but instead let the read half of the socket
# process whatever server reply there is to get.
set state(posterror) $err
set done 1
}
if {$done} {
catch {flush $s}
fileevent $s writable {}
fileevent $s readable [list http::Event $token]
}
# Callback to the client after we've completely handled everything.
if {[string length $state(-queryprogress)]} {
eval $state(-queryprogress) [list $token $state(querylength)\
$state(queryoffset)]
}
}
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
upvar 0 $token state
set s $state(sock)
if {[eof $s]} {
Eof $token
return
}
| | | > | | | | | | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
upvar 0 $token state
set s $state(sock)
if {[eof $s]} {
Eof $token
return
}
if {$state(state) eq "header"} {
if {[catch {gets $s line} n]} {
Finish $token $n
} elseif {$n == 0} {
variable encodings
set state(state) body
if {$state(-binary) || ![string match -nocase text* $state(type)]
|| [string match *gzip* $state(coding)]
|| [string match *compress* $state(coding)]} {
# Turn off conversions for non-text data
fconfigure $s -translation binary
if {[info exists state(-channel)]} {
fconfigure $state(-channel) -translation binary
}
} else {
# If we are getting text, set the incoming channel's encoding
# correctly. iso8859-1 is the RFC default, but this could be
# any IANA charset. However, we only know how to convert what
# we have encodings for.
set idx [lsearch -exact $encodings \
[string tolower $state(charset)]]
if {$idx >= 0} {
fconfigure $s -encoding [lindex $encodings $idx]
}
}
if {[info exists state(-channel)] && \
|
| ︙ | ︙ | |||
712 713 714 715 716 717 718 |
set state(totalsize) [string trim $length]
}
if {[regexp -nocase {^content-encoding:(.+)$} $line x coding]} {
set state(coding) [string trim $coding]
}
if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
lappend state(meta) $key [string trim $value]
| | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
set state(totalsize) [string trim $length]
}
if {[regexp -nocase {^content-encoding:(.+)$} $line x coding]} {
set state(coding) [string trim $coding]
}
if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
lappend state(meta) $key [string trim $value]
} elseif {[string match HTTP* $line]} {
set state(http) $line
}
}
} else {
if {[catch {
if {[info exists state(-handler)]} {
set n [eval $state(-handler) {$s $token}]
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
#
# Side Effects
# Clean up the socket
proc http::Eof {token} {
variable $token
upvar 0 $token state
| | | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 |
#
# Side Effects
# Clean up the socket
proc http::Eof {token} {
variable $token
upvar 0 $token state
if {$state(state) eq "header"} {
# Premature eof
set state(status) eof
} else {
set state(status) ok
}
set state(state) eof
Finish $token
|
| ︙ | ︙ | |||
839 840 841 842 843 844 845 |
}
return $state(status)
}
# http::formatQuery --
#
| | < | | | | | | | | | | | > > | | | > > > > > | | | 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 |
}
return $state(status)
}
# http::formatQuery --
#
# See documentaion for details. Call http::formatQuery with an even
# number of arguments, where the first is a name, the second is a value,
# the third is another name, and so on.
#
# Arguments:
# args A list of name-value pairs.
#
# Results:
# TODO
proc http::formatQuery {args} {
set result ""
set sep ""
foreach i $args {
append result $sep [mapReply $i]
if {$sep eq "="} {
set sep &
} else {
set sep =
}
}
return $result
}
# http::mapReply --
#
# Do x-www-urlencoded character mapping
#
# Arguments:
# string The string the needs to be encoded
#
# Results:
# The encoded string
proc http::mapReply {string} {
variable http
variable formMap
# The spec says: "non-alphanumeric characters are replaced by '%HH'". Use
# a pre-computed map and [string map] to do the conversion (much faster
# than [regsub]/[subst]). [Bug 1020491]
if {$http(-urlencoding) ne ""} {
set string [encoding convertto $http(-urlencoding) $string]
return [string map $formMap $string]
}
set converted [string map $formMap $string]
if {[string match "*\[\u0100-\uffff\]*" $converted]} {
regexp {[\u0100-\uffff]} $converted badChar
# Return this error message for maximum compatability... :^/
return -code error \
"can't read \"formMap($badChar)\": no such element in array"
}
return $converted
}
# http::ProxyRequired --
# Default proxy filter.
#
# Arguments:
# host The destination host
#
# Results:
# The current proxy settings
|
| ︙ | ︙ |
Changes to library/http/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. | | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.4]} {return}
package ifneeded http 2.5.3 [list tclPkgSetup $dir http 2.5.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
|
Changes to library/init.tcl.
1 2 3 4 5 | # init.tcl -- # # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # init.tcl -- # # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # # RCS: @(#) $Id: init.tcl,v 1.55.2.6 2005/07/22 21:59:40 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
namespace eval tcl {
variable Dir
| | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
namespace eval tcl {
variable Dir
if {[info library] ne ""} {
foreach Dir [list [info library] [file dirname [info library]]] {
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
}
}
set Dir [file join [file dirname [file dirname \
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
}
}
}
}
# Windows specific end of initialization
| | | | | | | | | | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 |
}
}
}
}
# Windows specific end of initialization
if {(![interp issafe]) && $tcl_platform(platform) eq "windows"} {
namespace eval tcl {
proc EnvTraceProc {lo n1 n2 op} {
set x $::env($n2)
set ::env($lo) $x
set ::env([string toupper $lo]) $x
}
proc InitWinEnv {} {
global env tcl_platform
foreach p [array names env] {
set u [string toupper $p]
if {$u ne $p} {
switch -- $u {
COMSPEC -
PATH {
if {![info exists env($u)]} {
set env($u) $env($p)
}
trace add variable env($p) write \
[namespace code [list EnvTraceProc $p]]
trace add variable env($u) write \
[namespace code [list EnvTraceProc $p]]
}
}
}
}
if {![info exists env(COMSPEC)]} {
if {$tcl_platform(os) eq "Windows NT"} {
set env(COMSPEC) cmd.exe
} else {
set env(COMSPEC) command.com
}
}
}
InitWinEnv
}
}
# Setup the unknown package handler
package unknown tclPkgUnknown
if {![interp issafe]} {
# setup platform specific unknown package handlers
if {$::tcl_platform(platform) eq "unix"
&& $::tcl_platform(os) eq "Darwin"} {
package unknown [list tcl::MacOSXPkgUnknown [package unknown]]
}
if {$::tcl_platform(platform) eq "macintosh"} {
package unknown [list tcl::MacPkgUnknown [package unknown]]
}
}
# Conditionalize for presence of exec.
if {[namespace which -command exec] eq ""} {
# Some machines, such as the Macintosh, do not have exec. Also, on all
# platforms, safe interpreters do not have exec.
set auto_noexec 1
}
set errorCode ""
set errorInfo ""
# Define a log command (which can be overwitten to log errors
# differently, specially when stderr is not available)
if {[namespace which -command tclLog] eq ""} {
proc tclLog {string} {
catch {puts stderr $string}
}
}
# unknown --
# This procedure is called when a Tcl command is invoked that doesn't
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 192 193 |
}
}
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
| > > > > > > > > | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
}
}
# Save the values of errorCode and errorInfo variables, since they
# may get modified if caught errors occur below. The variables will
# be restored just before re-executing the missing command.
# Safety check in case something unsets the variables
# ::errorInfo or ::errorCode. [Bug 1063707]
if {![info exists errorCode]} {
set errorCode ""
}
if {![info exists errorInfo]} {
set errorInfo ""
}
set savedErrorCode $errorCode
set savedErrorInfo $errorInfo
set name $cmd
if {![info exists auto_noload]} {
#
# Make sure we're not trying to load the same proc twice.
#
if {[info exists unknown_pending($name)]} {
return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
}
|
| ︙ | ︙ | |||
216 217 218 219 220 221 222 |
if {$code == 1} {
#
# Compute stack trace contribution from the [uplevel].
# Note the dependence on how Tcl_AddErrorInfo, etc.
# construct the stack trace.
#
set cinfo $args
| > | | > | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 |
if {$code == 1} {
#
# Compute stack trace contribution from the [uplevel].
# Note the dependence on how Tcl_AddErrorInfo, etc.
# construct the stack trace.
#
set cinfo $args
set ellipsis ""
while {[string bytelength $cinfo] > 150} {
set cinfo [string range $cinfo 0 end-1]
set ellipsis "..."
}
append cinfo $ellipsis "\"\n (\"uplevel\" body line 1)"
append cinfo "\n invoked from within"
append cinfo "\n\"uplevel 1 \$args\""
#
# Try each possible form of the stack trace
# and trim the extra contribution from the matching case
#
set expect "$msg\n while executing\n\"$cinfo"
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
-errorinfo $einfo $msg
} else {
return -code $code $msg
}
}
}
| | | | | | | | | | > > > > > > > > > > > > > > > > | < < < < | < | | > > | > > > > > > > | < < < < < < | < | < < | | | | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 |
-errorinfo $einfo $msg
} else {
return -code $code $msg
}
}
}
if {([info level] == 1) && [info script] eq "" \
&& [info exists tcl_interactive] && $tcl_interactive} {
if {![info exists auto_noexec]} {
set new [auto_execok $name]
if {$new ne ""} {
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
set redir ""
if {[namespace which -command console] eq ""} {
set redir ">&@stdout <@stdin"
}
return [uplevel 1 exec $redir $new [lrange $args 1 end]]
}
}
set errorCode $savedErrorCode
set errorInfo $savedErrorInfo
if {$name eq "!!"} {
set newcmd [history event]
} elseif {[regexp {^!(.+)$} $name -> event]} {
set newcmd [history event $event]
} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
set newcmd [history event -1]
catch {regsub -all -- $old $newcmd $new newcmd}
}
if {[info exists newcmd]} {
tclLog $newcmd
history change $newcmd 0
return [uplevel 1 $newcmd]
}
set ret [catch {set candidates [info commands $name*]} msg]
if {$name eq "::"} {
set name ""
}
if {$ret != 0} {
return -code $ret -errorcode $errorCode \
"error in unknown while checking if \"$name\" is\
a unique command abbreviation:\n$msg"
}
# Handle empty $name separately due to strangeness in [string first]
if {$name eq ""} {
if {[llength $candidates] != 1} {
return -code error "empty command name \"\""
}
return [uplevel 1 [lreplace $args 0 0 [lindex $candidates 0]]]
}
# Filter out bogus matches when $name contained
# a glob-special char [Bug 946952]
set cmds [list]
foreach x $candidates {
if {[string first $name $x] == 0} {
lappend cmds $x
}
}
if {[llength $cmds] == 1} {
return [uplevel 1 [lreplace $args 0 0 [lindex $cmds 0]]]
}
if {[llength $cmds]} {
return -code error "ambiguous command name \"$name\": [lsort $cmds]"
}
}
return -code error "invalid command name \"$name\""
}
# auto_load --
# Checks a collection of library directories to see if a procedure
# is defined in one of them. If so, it sources the appropriate
# library file to create the procedure. Returns 1 if it successfully
# loaded the procedure, 0 otherwise.
#
# Arguments:
# cmd - Name of the command to find and load.
# namespace (optional) The namespace where the command is being used - must be
# a canonical namespace as returned [namespace current]
# for instance. If not given, namespace current is used.
proc auto_load {cmd {namespace {}}} {
global auto_index auto_oldpath auto_path
if {$namespace eq ""} {
set namespace [uplevel 1 [list ::namespace current]]
}
set nameList [auto_qualify $cmd $namespace]
# workaround non canonical auto_index entries that might be around
# from older auto_mkindex versions
lappend nameList $cmd
foreach name $nameList {
if {[info exists auto_index($name)]} {
namespace eval :: $auto_index($name)
# There's a couple of ways to look for a command of a given
# name. One is to use
# info commands $name
# Unfortunately, if the name has glob-magic chars in it like *
# or [], it may not match. For our purposes here, a better
# route is to use
# namespace which -command $name
if {[namespace which -command $name] ne ""} {
return 1
}
}
}
if {![info exists auto_path]} {
return 0
}
if {![auto_load_index]} {
return 0
}
foreach name $nameList {
if {[info exists auto_index($name)]} {
namespace eval :: $auto_index($name)
if {[namespace which -command $name] ne ""} {
return 1
}
}
}
return 0
}
# auto_load_index --
# Loads the contents of tclIndex files on the auto_path directory
# list. This is usually invoked within auto_load to load the index
# of available commands. Returns 1 if the index is loaded, and 0 if
# the index is already loaded and up to date.
#
# Arguments:
# None.
proc auto_load_index {} {
global auto_index auto_oldpath auto_path errorInfo errorCode
if {[info exists auto_oldpath] && $auto_oldpath eq $auto_path} {
return 0
}
set auto_oldpath $auto_path
# Check if we are a safe interpreter. In that case, we support only
# newer format tclIndex files.
set issafe [interp issafe]
for {set i [expr {[llength $auto_path] - 1}]} {$i >= 0} {incr i -1} {
set dir [lindex $auto_path $i]
set f ""
if {$issafe} {
catch {source [file join $dir tclIndex]}
} elseif {[catch {set f [open [file join $dir tclIndex]]}]} {
continue
} else {
set error [catch {
set id [gets $f]
if {$id eq "# Tcl autoload index file, version 2.0"} {
eval [read $f]
} elseif {$id eq "# Tcl autoload index file: each line identifies a Tcl"} {
while {[gets $f line] >= 0} {
if {[string index $line 0] eq "#"
|| ([llength $line] != 2)} {
continue
}
set name [lindex $line 0]
set auto_index($name) \
"source [file join $dir [lindex $line 1]]"
}
} else {
error "[file join $dir tclIndex] isn't a proper Tcl index file"
}
} msg]
if {$f ne ""} {
close $f
}
if {$error} {
error $msg $errorInfo $errorCode
}
}
}
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 |
# Ignore namespace if the name starts with ::
# Handle special case of only leading ::
# Before each return case we give an example of which category it is
# with the following form :
# ( inputCmd, inputNameSpace) -> output
| | | | | | 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
# Ignore namespace if the name starts with ::
# Handle special case of only leading ::
# Before each return case we give an example of which category it is
# with the following form :
# ( inputCmd, inputNameSpace) -> output
if {[string match ::* $cmd]} {
if {$n > 1} {
# ( ::foo::bar , * ) -> ::foo::bar
return [list $cmd]
} else {
# ( ::global , * ) -> global
return [list [string range $cmd 2 end]]
}
}
# Potentially returning 2 elements to try :
# (if the current namespace is not the global one)
if {$n == 0} {
if {$namespace eq "::"} {
# ( nocolons , :: ) -> nocolons
return [list $cmd]
} else {
# ( nocolons , ::sub ) -> ::sub::nocolons nocolons
return [list ${namespace}::$cmd $cmd]
}
} elseif {$namespace eq "::"} {
# ( foo::bar , :: ) -> ::foo::bar
return [list ::$cmd]
} else {
# ( foo::bar , ::sub ) -> ::sub::foo::bar ::foo::bar
return [list ${namespace}::$cmd ::$cmd]
}
}
|
| ︙ | ︙ | |||
510 511 512 513 514 515 516 |
set ns [uplevel 1 [list ::namespace current]]
set patternList [auto_qualify $pattern $ns]
auto_load_index
foreach pattern $patternList {
foreach name [array names auto_index $pattern] {
| < | | | | | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 |
set ns [uplevel 1 [list ::namespace current]]
set patternList [auto_qualify $pattern $ns]
auto_load_index
foreach pattern $patternList {
foreach name [array names auto_index $pattern] {
if {([namespace which -command $name] eq "")
&& ([namespace qualifiers $pattern] eq [namespace qualifiers $name])} {
namespace eval :: $auto_index($name)
}
}
}
}
# auto_execok --
#
# Returns string that indicates name of program to execute if
# name corresponds to a shell builtin or an executable in the
# Windows search path, or "" otherwise. Builds an associative
# array auto_execs that caches information about previous checks,
# for speed.
#
# Arguments:
# name - Name of a command.
if {$tcl_platform(platform) eq "windows"} {
# Windows version.
#
# Note that info executable doesn't work under Windows, so we have to
# look for files with .exe, .com, or .bat extensions. Also, the path
# may be in the Path or PATH environment variables, and path
# components are separated with semicolons, not colons as under Unix.
#
proc auto_execok name {
global auto_execs env tcl_platform
if {[info exists auto_execs($name)]} {
return $auto_execs($name)
}
set auto_execs($name) ""
set shellBuiltins [list cls copy date del erase dir echo mkdir \
md rename ren rmdir rd time type ver vol]
if {$tcl_platform(os) eq "Windows NT"} {
# NT includes the 'start' built-in
lappend shellBuiltins "start"
}
if {[info exists env(PATHEXT)]} {
# Add an initial ; to have the {} extension check first.
set execExtensions [split ";$env(PATHEXT)" ";"]
} else {
|
| ︙ | ︙ | |||
585 586 587 588 589 590 591 |
}
set path "[file dirname [info nameof]];.;"
if {[info exists env(WINDIR)]} {
set windir $env(WINDIR)
}
if {[info exists windir]} {
| | | | 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 |
}
set path "[file dirname [info nameof]];.;"
if {[info exists env(WINDIR)]} {
set windir $env(WINDIR)
}
if {[info exists windir]} {
if {$tcl_platform(os) eq "Windows NT"} {
append path "$windir/system32;"
}
append path "$windir/system;$windir;"
}
foreach var {PATH Path path} {
if {[info exists env($var)]} {
append path ";$env($var)"
}
}
foreach dir [split $path {;}] {
# Skip already checked directories
if {[info exists checked($dir)] || $dir eq {}} { continue }
set checked($dir) {}
foreach ext $execExtensions {
set file [file join $dir ${name}${ext}]
if {[file exists $file] && ![file isdirectory $file]} {
return [set auto_execs($name) [list $file]]
}
}
|
| ︙ | ︙ | |||
628 629 630 631 632 633 634 |
if {[llength [file split $name]] != 1} {
if {[file executable $name] && ![file isdirectory $name]} {
set auto_execs($name) [list $name]
}
return $auto_execs($name)
}
foreach dir [split $env(PATH) :] {
| | | 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 |
if {[llength [file split $name]] != 1} {
if {[file executable $name] && ![file isdirectory $name]} {
set auto_execs($name) [list $name]
}
return $auto_execs($name)
}
foreach dir [split $env(PATH) :] {
if {$dir eq ""} {
set dir .
}
set file [file join $dir $name]
if {[file executable $file] && ![file isdirectory $file]} {
set auto_execs($name) [list $file]
return $auto_execs($name)
}
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 |
# Arguments:
# action - "renaming" or "copying"
# src - source directory
# dest - destination directory
proc tcl::CopyDirectory {action src dest} {
set nsrc [file normalize $src]
set ndest [file normalize $dest]
| | | | | | > | | | | 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 |
# Arguments:
# action - "renaming" or "copying"
# src - source directory
# dest - destination directory
proc tcl::CopyDirectory {action src dest} {
set nsrc [file normalize $src]
set ndest [file normalize $dest]
if {$action eq "renaming"} {
# Can't rename volumes. We could give a more precise
# error message here, but that would break the test suite.
if {[lsearch -exact [file volumes] $nsrc] != -1} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
}
if {[file exists $dest]} {
if {$nsrc eq $ndest} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
if {$action eq "copying"} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
} else {
# Depending on the platform, and on the current
# working directory, the directories '.', '..'
# can be returned in various combinations. Anyway,
# if any other file is returned, we must signal an error.
set existing [glob -nocomplain -directory $dest * .*]
eval [linsert \
[glob -nocomplain -directory $dest -type hidden * .*] 0 \
lappend existing]
foreach s $existing {
if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
return -code error "error $action \"$src\" to\
\"$dest\": file already exists"
}
}
}
} else {
if {[string first $nsrc $ndest] != -1} {
set srclen [expr {[llength [file split $nsrc]] -1}]
set ndest [lindex [file split $ndest] $srclen]
if {$ndest eq [file tail $nsrc]} {
return -code error "error $action \"$src\" to\
\"$dest\": trying to rename a volume or move a directory\
into itself"
}
}
file mkdir $dest
}
# Have to be careful to capture both visible and hidden files.
# We will also be more generous to the file system and not
# assume the hidden and non-hidden lists are non-overlapping.
#
# On Unix 'hidden' files begin with '.'. On other platforms
# or filesystems hidden files may have other interpretations.
set filelist [concat [glob -nocomplain -directory $src *] \
[glob -nocomplain -directory $src -types hidden *]]
foreach s [lsort -unique $filelist] {
if {([file tail $s] ne ".") && ([file tail $s] ne "..")} {
file copy $s [file join $dest [file tail $s]]
}
}
return
}
|
Changes to library/msgcat/msgcat.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 | # msgcat.tcl -- # # This file defines various procedures which implement a # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 1998 by Mark Harrison. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
# msgcat.tcl --
#
# This file defines various procedures which implement a
# message catalog facility for Tcl programs. It should be
# loaded with the command "package require msgcat".
#
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 1998 by Mark Harrison.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: msgcat.tcl,v 1.17.2.6 2006/09/10 18:23:45 dgp Exp $
package require Tcl 8.2
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.3.4
namespace eval msgcat {
namespace export mc mcload mclocale mcmax mcmset mcpreferences mcset \
mcunknown
# Records the current locale as passed to mclocale
variable Locale ""
# Records the list of locales to search
variable Loclist {}
# Records the mapping between source strings and translated strings. The
# array key is of the form "<locale>,<namespace>,<src>" and the value is
# the translated string.
array set Msgs {}
# Map of language codes used in Windows registry to those of ISO-639
if { [string equal $::tcl_platform(platform) windows] } {
array set WinRegToISO639 {
01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ
1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY
2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH
4001 ar_QA
02 bg 0402 bg_BG
03 ca 0403 ca_ES
04 zh 0404 zh_TW 0804 zh_CN 0c04 zh_HK 1004 zh_SG 1404 zh_MO
05 cs 0405 cs_CZ
06 da 0406 da_DK
07 de 0407 de_DE 0807 de_CH 0c07 de_AT 1007 de_LU 1407 de_LI
08 el 0408 el_GR
09 en 0409 en_US 0809 en_GB 0c09 en_AU 1009 en_CA 1409 en_NZ
1809 en_IE 1c09 en_ZA 2009 en_JM 2409 en_GD 2809 en_BZ
2c09 en_TT 3009 en_ZW 3409 en_PH
0a es 040a es_ES 080a es_MX 0c0a es_ES@modern 100a es_GT 140a es_CR
180a es_PA 1c0a es_DO 200a es_VE 240a es_CO 280a es_PE
2c0a es_AR 300a es_EC 340a es_CL 380a es_UY 3c0a es_PY
400a es_BO 440a es_SV 480a es_HN 4c0a es_NI 500a es_PR
0b fi 040b fi_FI
0c fr 040c fr_FR 080c fr_BE 0c0c fr_CA 100c fr_CH 140c fr_LU
180c fr_MC
0d he 040d he_IL
0e hu 040e hu_HU
0f is 040f is_IS
10 it 0410 it_IT 0810 it_CH
11 ja 0411 ja_JP
12 ko 0412 ko_KR
13 nl 0413 nl_NL 0813 nl_BE
14 no 0414 no_NO 0814 nn_NO
15 pl 0415 pl_PL
16 pt 0416 pt_BR 0816 pt_PT
17 rm 0417 rm_CH
18 ro 0418 ro_RO
19 ru
1a hr 041a hr_HR 081a sr_YU 0c1a sr_YU@cyrillic
1b sk 041b sk_SK
1c sq 041c sq_AL
1d sv 041d sv_SE 081d sv_FI
1e th 041e th_TH
1f tr 041f tr_TR
20 ur 0420 ur_PK 0820 ur_IN
21 id 0421 id_ID
22 uk 0422 uk_UA
23 be 0423 be_BY
24 sl 0424 sl_SI
25 et 0425 et_EE
26 lv 0426 lv_LV
27 lt 0427 lt_LT
28 tg 0428 tg_TJ
29 fa 0429 fa_IR
2a vi 042a vi_VN
2b hy 042b hy_AM
2c az 042c az_AZ@latin 082c az_AZ@cyrillic
2d eu
2e wen 042e wen_DE
2f mk 042f mk_MK
30 bnt 0430 bnt_TZ
31 ts 0431 ts_ZA
33 ven 0433 ven_ZA
34 xh 0434 xh_ZA
35 zu 0435 zu_ZA
36 af 0436 af_ZA
37 ka 0437 ka_GE
38 fo 0438 fo_FO
39 hi 0439 hi_IN
3a mt 043a mt_MT
3b se 043b se_NO
043c gd_UK 083c ga_IE
3d yi 043d yi_IL
3e ms 043e ms_MY 083e ms_BN
3f kk 043f kk_KZ
40 ky 0440 ky_KG
41 sw 0441 sw_KE
42 tk 0442 tk_TM
43 uz 0443 uz_UZ@latin 0843 uz_UZ@cyrillic
44 tt 0444 tt_RU
45 bn 0445 bn_IN
46 pa 0446 pa_IN
47 gu 0447 gu_IN
48 or 0448 or_IN
49 ta
4a te 044a te_IN
4b kn 044b kn_IN
4c ml 044c ml_IN
4d as 044d as_IN
4e mr 044e mr_IN
4f sa 044f sa_IN
50 mn
51 bo 0451 bo_CN
52 cy 0452 cy_GB
53 km 0453 km_KH
54 lo 0454 lo_LA
55 my 0455 my_MM
56 gl 0456 gl_ES
57 kok 0457 kok_IN
58 mni 0458 mni_IN
59 sd
5a syr 045a syr_TR
5b si 045b si_LK
5c chr 045c chr_US
5d iu 045d iu_CA
5e am 045e am_ET
5f ber 045f ber_MA
60 ks 0460 ks_PK 0860 ks_IN
61 ne 0461 ne_NP 0861 ne_IN
62 fy 0462 fy_NL
63 ps
64 tl 0464 tl_PH
65 div 0465 div_MV
66 bin 0466 bin_NG
67 ful 0467 ful_NG
68 ha 0468 ha_NG
69 nic 0469 nic_NG
6a yo 046a yo_NG
70 ibo 0470 ibo_NG
71 kau 0471 kau_NG
72 om 0472 om_ET
73 ti 0473 ti_ET
74 gn 0474 gn_PY
75 cpe 0475 cpe_US
76 la 0476 la_VA
77 so 0477 so_SO
78 sit 0478 sit_CN
79 pap 0479 pap_AN
}
}
}
# msgcat::mc --
#
# Find the translation for the given string based on the current
# locale setting. Check the local namespace first, then look in each
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
set len [llength $args]
if {$len > 1} {
error {wrong # args: should be "mclocale ?newLocale?"}
}
if {$len == 1} {
| > > > > > | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
set len [llength $args]
if {$len > 1} {
error {wrong # args: should be "mclocale ?newLocale?"}
}
if {$len == 1} {
set newLocale [lindex $args 0]
if {$newLocale ne [file tail $newLocale]} {
return -code error "invalid newLocale value \"$newLocale\":\
could be path to unsafe code."
}
set Locale [string tolower $newLocale]
set Loclist {}
set word ""
foreach part [split $Locale _] {
set word [string trimleft "${word}_${part}" _]
set Loclist [linsert $Loclist 0 $word]
}
}
|
| ︙ | ︙ | |||
291 292 293 294 295 296 297 |
# the source string is used.
#
# Results:
# Returns the new locale.
proc msgcat::mcset {locale src {dest ""}} {
variable Msgs
| | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
# the source string is used.
#
# Results:
# Returns the new locale.
proc msgcat::mcset {locale src {dest ""}} {
variable Msgs
if {[llength [info level 0]] == 3} { ;# dest not specified
set dest $src
}
set ns [uplevel 1 [list ::namespace current]]
set Msgs([string tolower $locale],$ns,$src) $dest
return $dest
}
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
# ^ # Match all the way to the beginning
# ([^_.@]*) # Match "lanugage"; ends with _, ., or @
# (_([^.@]*))? # Match (optional) "territory"; starts with _
# ([.]([^@]*))? # Match (optional) "codeset"; starts with .
# (@(.*))? # Match (optional) "modifier"; starts with @
# $ # Match all the way to the end
# } $value -> language _ territory _ codeset _ modifier
| | | > > | > > > > > > > > > > > > > > > > > > > > | < | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 |
# ^ # Match all the way to the beginning
# ([^_.@]*) # Match "lanugage"; ends with _, ., or @
# (_([^.@]*))? # Match (optional) "territory"; starts with _
# ([.]([^@]*))? # Match (optional) "codeset"; starts with .
# (@(.*))? # Match (optional) "modifier"; starts with @
# $ # Match all the way to the end
# } $value -> language _ territory _ codeset _ modifier
if {![regexp {^([^_.@]+)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \
-> language _ territory _ codeset _ modifier]} {
return -code error "invalid locale '$value': empty language part"
}
set ret $language
if {[string length $territory]} {
append ret _$territory
}
if {[string length $modifier]} {
append ret _$modifier
}
return $ret
}
# Initialize the default locale
proc msgcat::Init {} {
#
# set default locale, try to get from environment
#
foreach varName {LC_ALL LC_MESSAGES LANG} {
if {[info exists ::env($varName)]
&& ![string equal "" $::env($varName)]} {
if {![catch {mclocale [ConvertLocale $::env($varName)]}]} {
return
}
}
}
#
# On Darwin, fallback to current CFLocale identifier if available.
#
if {[string equal $::tcl_platform(os) Darwin]
&& [string equal $::tcl_platform(platform) unix]
&& [info exists ::tcl::mac::locale]
&& ![string equal $::tcl::mac::locale ""]} {
if {![catch {mclocale [ConvertLocale $::tcl::mac::locale]}]} {
return
}
}
#
# The rest of this routine is special processing for Windows;
# all other platforms, get out now.
#
if { ![string equal $::tcl_platform(platform) windows] } {
mclocale C
return
}
#
# On Windows, try to set locale depending on registry settings,
# or fall back on locale of "C".
#
set key {HKEY_CURRENT_USER\Control Panel\International}
if {[catch {package require registry}] \
|| [catch {registry get $key "locale"} locale]} {
mclocale C
return
}
|
| ︙ | ︙ |
Changes to library/msgcat/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded msgcat 1.3.4 [list source [file join $dir msgcat.tcl]]
|
Changes to library/opt/optparse.tcl.
1 2 3 4 5 6 7 8 9 10 | # optparse.tcl -- # # (private) Option parsing package # Primarily used internally by the safe:: code. # # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely # on it. If your code does rely on this package you # may directly incorporate this code into your application. # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# optparse.tcl --
#
# (private) Option parsing package
# Primarily used internally by the safe:: code.
#
# WARNING: This code will go away in a future release
# of Tcl. It is NOT supported and you should not rely
# on it. If your code does rely on this package you
# may directly incorporate this code into your application.
#
# RCS: @(#) $Id: optparse.tcl,v 1.8.2.1 2003/09/10 20:29:59 dgp Exp $
package require Tcl 8.2
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
package provide opt 0.4.4.1
namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
OptProc OptProcArgGiven OptParse \
Lempty Lget \
|
| ︙ | ︙ |
Changes to library/opt/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. | | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.2]} {return}
package ifneeded opt 0.4.4.1 [list source [file join $dir optparse.tcl]]
|
Changes to library/package.tcl.
1 2 3 4 5 | # package.tcl -- # # utility procs formerly in init.tcl which can be loaded on demand # for package management. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # package.tcl -- # # utility procs formerly in init.tcl which can be loaded on demand # for package management. # # RCS: @(#) $Id: package.tcl,v 1.23.2.4 2006/09/22 01:26:24 andreas_kupries Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 |
# Defaults to [info sharedlibextension]
#
# Results:
# Returns 1 if the extension matches, 0 otherwise
proc pkg_compareExtension { fileName {ext {}} } {
global tcl_platform
| | | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
# Defaults to [info sharedlibextension]
#
# Results:
# Returns 1 if the extension matches, 0 otherwise
proc pkg_compareExtension { fileName {ext {}} } {
global tcl_platform
if {$ext eq ""} {set ext [info sharedlibextension]}
if {$tcl_platform(platform) eq "windows"} {
return [string equal -nocase [file extension $fileName] $ext]
} else {
# Some unices add trailing numbers after the .so, so
# we could have something like '.so.1.2'.
set root $fileName
while {1} {
set currExt [file extension $root]
if {$currExt eq $ext} {
return 1
}
# The current extension does not match; if it is not a numeric
# value, quit, as we are only looking to ignore version number
# extensions. Otherwise we might return 1 in this case:
# pkg_compareExtension foo.so.bar .so
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
if {[llength $patternList] == 0} {
set patternList [list "*.tcl" "*[info sharedlibextension]"]
}
set oldDir [pwd]
cd $dir
| | | | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
if {[llength $patternList] == 0} {
set patternList [list "*.tcl" "*[info sharedlibextension]"]
}
set oldDir [pwd]
cd $dir
if {[catch {eval [linsert $patternList 0 glob --]} fileList]} {
global errorCode errorInfo
cd $oldDir
return -code error -errorcode $errorCode -errorinfo $errorInfo $fileList
}
foreach file $fileList {
# For each file, figure out what commands and packages it provides.
# To do this, create a child interpreter, load the file into the
# interpreter, and get a list of the new commands and packages
# that are defined.
if {$file eq "pkgIndex.tcl"} {
continue
}
# Changed back to the original directory before initializing the
# slave in case TCL_LIBRARY is a relative path (e.g. in the test
# suite).
cd $oldDir
set c [interp create]
# Load into the child any packages currently loaded in the parent
# interpreter that match the -load pattern.
if {$loadPat ne ""} {
if {$doVerbose} {
tclLog "currently loaded packages: '[info loaded]'"
tclLog "trying to load all packages matching $loadPat"
}
if {![llength [info loaded]]} {
tclLog "warning: no packages are currently loaded, nothing"
tclLog "can possibly match '$loadPat'"
|
| ︙ | ︙ | |||
187 188 189 190 191 192 193 |
} err]} {
if {$doVerbose} {
tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
}
} elseif {$doVerbose} {
tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
| | | | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 |
} err]} {
if {$doVerbose} {
tclLog "warning: load [lindex $pkg 0] [lindex $pkg 1]\nfailed with: $err"
}
} elseif {$doVerbose} {
tclLog "loaded [lindex $pkg 0] [lindex $pkg 1]"
}
if {[lindex $pkg 1] eq "Tk"} {
# Withdraw . if Tk was loaded, to avoid showing a window.
$c eval [list wm withdraw .]
}
}
cd $dir
$c eval {
# Stub out the package command so packages can
# require other packages.
rename package __package_orig
proc package {what args} {
switch -- $what {
require { return ; # ignore transitive requires }
default { uplevel 1 [linsert $args 0 __package_orig $what] }
}
}
proc tclPkgUnknown args {}
package unknown tclPkgUnknown
# Stub out the unknown command so package can call
# into each other during their initialilzation.
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
# we need to track command defined by each package even in
# the -direct case, because they are needed internally by
# the "partial pkgIndex.tcl" step above.
proc ::tcl::GetAllNamespaces {{root ::}} {
set list $root
foreach ns [namespace children $root] {
| | > > | > | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 |
# we need to track command defined by each package even in
# the -direct case, because they are needed internally by
# the "partial pkgIndex.tcl" step above.
proc ::tcl::GetAllNamespaces {{root ::}} {
set list $root
foreach ns [namespace children $root] {
eval [linsert [::tcl::GetAllNamespaces $ns] 0 \
lappend list]
}
return $list
}
# init the list of existing namespaces, packages, commands
foreach ::tcl::x [::tcl::GetAllNamespaces] {
set ::tcl::namespaces($::tcl::x) 1
}
foreach ::tcl::x [package names] {
if {[package provide $::tcl::x] ne ""} {
set ::tcl::packages($::tcl::x) 1
}
}
set ::tcl::origCmds [info commands]
# Try to load the file if it has the shared library
# extension, otherwise source it. It's important not to
# try to load files that aren't shared libraries, because
# on some systems (like SunOS) the loader will abort the
|
| ︙ | ︙ | |||
314 315 316 317 318 319 320 |
# Figure out what commands appeared
foreach ::tcl::x [info commands] {
set ::tcl::newCmds($::tcl::x) 1
}
foreach ::tcl::x $::tcl::origCmds {
| | | | > | > | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
# Figure out what commands appeared
foreach ::tcl::x [info commands] {
set ::tcl::newCmds($::tcl::x) 1
}
foreach ::tcl::x $::tcl::origCmds {
unset -nocomplain ::tcl::newCmds($::tcl::x)
}
foreach ::tcl::x [array names ::tcl::newCmds] {
# determine which namespace a command comes from
set ::tcl::abs [namespace origin $::tcl::x]
# special case so that global names have no leading
# ::, this is required by the unknown command
set ::tcl::abs \
[lindex [auto_qualify $::tcl::abs ::] 0]
if {$::tcl::x ne $::tcl::abs} {
# Name changed during qualification
set ::tcl::newCmds($::tcl::abs) 1
unset ::tcl::newCmds($::tcl::x)
}
}
}
}
# Look through the packages that appeared, and if there is
# a version provided, then record it
foreach ::tcl::x [package names] {
if {[package provide $::tcl::x] ne ""
&& ![info exists ::tcl::packages($::tcl::x)]} {
lappend ::tcl::newPkgs \
[list $::tcl::x [package provide $::tcl::x]]
}
}
}
} msg] == 1} {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "warning: error while $what $file: $msg"
}
} else {
set what [$c eval set ::tcl::debug]
if {$doVerbose} {
tclLog "successful $what of $file"
}
set type [$c eval set ::tcl::type]
set cmds [lsort [$c eval array names ::tcl::newCmds]]
set pkgs [$c eval set ::tcl::newPkgs]
if {$doVerbose} {
if { !$direct } {
tclLog "commands provided were $cmds"
}
tclLog "packages provided were $pkgs"
}
if {[llength $pkgs] > 1} {
tclLog "warning: \"$file\" provides more than one package ($pkgs)"
}
foreach pkg $pkgs {
# cmds is empty/not used in the direct case
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
global auto_index
package provide $pkg $version
foreach fileInfo $files {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
| | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
global auto_index
package provide $pkg $version
foreach fileInfo $files {
set f [lindex $fileInfo 0]
set type [lindex $fileInfo 1]
foreach cmd [lindex $fileInfo 2] {
if {$type eq "load"} {
set auto_index($cmd) [list load [file join $dir $f] $pkg]
} else {
set auto_index($cmd) [list source [file join $dir $f]]
}
}
}
}
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 | # to the auto_path and scan any new directories. # # Arguments: # name - Name of desired package. Not used. # version - Version of desired package. Not used. # exact - Either "-exact" or omitted. Not used. | > | > > > > | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 |
# to the auto_path and scan any new directories.
#
# Arguments:
# name - Name of desired package. Not used.
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
proc tclPkgUnknown [expr {
[info exists tcl_platform(tip,268)]
? "name args"
: "name version {exact {}}"
}] {
global auto_path env
if {![info exists auto_path]} {
return
}
# Cache the auto_path, because it may change while we run through
# the first set of pkgIndex.tcl files
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 562 563 564 | # of the auto_path directories for pkgIndex files. # Only installed in interps that are not safe so we don't check # for [interp issafe] as in tclPkgUnknown. # # Arguments: # original - original [package unknown] procedure # name - Name of desired package. Not used. # version - Version of desired package. Not used. # exact - Either "-exact" or omitted. Not used. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
# of the auto_path directories for pkgIndex files.
# Only installed in interps that are not safe so we don't check
# for [interp issafe] as in tclPkgUnknown.
#
# Arguments:
# original - original [package unknown] procedure
# name - Name of desired package. Not used.
#ifndef TCL_TIP268
# version - Version of desired package. Not used.
# exact - Either "-exact" or omitted. Not used.
#else
# args - List of requirements. Not used.
#endif
if {[info exists tcl_platform(tip,268)]} {
proc tcl::MacOSXPkgUnknown {original name args} {
# First do the cross-platform default search
uplevel 1 $original [linsert $args 0 $name]
# Now do MacOSX specific searching
global auto_path
if {![info exists auto_path]} {
return
}
# Cache the auto_path, because it may change while we run through
# the first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
while {[llength $use_path]} {
set dir [lindex $use_path end]
# get the pkgIndex files out of the subdirectories
foreach file [glob -directory $dir -join -nocomplain \
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
if {[file readable $file] && ![info exists procdDirs($dir)]} {
if {[catch {source $file} msg]} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
if {$old_path ne $auto_path} {
foreach dir $auto_path {
lappend use_path $dir
}
set old_path $auto_path
}
}
}
} else {
proc tcl::MacOSXPkgUnknown {original name version {exact {}}} {
# First do the cross-platform default search
uplevel 1 $original [list $name $version $exact]
# Now do MacOSX specific searching
global auto_path
if {![info exists auto_path]} {
return
}
# Cache the auto_path, because it may change while we run through
# the first set of pkgIndex.tcl files
set old_path [set use_path $auto_path]
while {[llength $use_path]} {
set dir [lindex $use_path end]
# get the pkgIndex files out of the subdirectories
foreach file [glob -directory $dir -join -nocomplain \
* Resources Scripts pkgIndex.tcl] {
set dir [file dirname $file]
if {[file readable $file] && ![info exists procdDirs($dir)]} {
if {[catch {source $file} msg]} {
tclLog "error reading package index file $file: $msg"
} else {
set procdDirs($dir) 1
}
}
}
set use_path [lrange $use_path 0 end-1]
if {$old_path ne $auto_path} {
foreach dir $auto_path {
lappend use_path $dir
}
set old_path $auto_path
}
}
}
}
# tcl::MacPkgUnknown --
# This procedure extends the "package unknown" function for Mac.
# It searches for pkgIndex TEXT resources in all files
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
foreach x [concat [list $dir] [glob -directory $dir -nocomplain *] ] {
if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
set dir $x
foreach x [glob -directory $dir -nocomplain *.shlb] {
if {[file isfile $x]} {
set res [resource open $x]
foreach y [resource list TEXT $res] {
| | | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 |
foreach x [concat [list $dir] [glob -directory $dir -nocomplain *] ] {
if {[file isdirectory $x] && ![info exists procdDirs($x)]} {
set dir $x
foreach x [glob -directory $dir -nocomplain *.shlb] {
if {[file isfile $x]} {
set res [resource open $x]
foreach y [resource list TEXT $res] {
if {$y eq "pkgIndex"} {source -rsrc pkgIndex}
}
catch {resource close $res}
}
}
set procdDirs($dir) 1
}
}
set use_path [lrange $use_path 0 end-1]
if {$old_path ne $auto_path} {
foreach dir $auto_path {
lappend use_path $dir
}
set old_path $auto_path
}
}
}
|
| ︙ | ︙ |
Changes to library/reg/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8]} {return}
| > | | | | 1 2 3 4 5 6 7 8 9 |
if {![package vsatisfies [package provide Tcl] 8]} {return}
if {[string compare $::tcl_platform(platform) windows]} {return}
if {[info exists ::tcl_platform(debug)]} {
package ifneeded registry 1.1.5 \
[list load [file join $dir tclreg11g.dll] registry]
} else {
package ifneeded registry 1.1.5 \
[list load [file join $dir tclreg11.dll] registry]
}
|
Changes to library/safe.tcl.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # See the safe.n man page for details. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # See the safe.n man page for details. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: safe.tcl,v 1.9.2.3 2005/07/22 21:59:41 dgp Exp $ # # The implementation is based on namespaces. These naming conventions # are followed: # Private procs starts with uppercase. # Public procs are exported and starts with lowercase # |
| ︙ | ︙ | |||
32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
interpAddToAccessPath interpFindInAccessPath setLogCmd
####
#
# Setup the arguments parsing
#
####
# Share the descriptions
set temp [::tcl::OptKeyRegister {
{-accessPath -list {} "access path for the slave"}
{-noStatics "prevent loading of statically linked pkgs"}
{-statics true "loading of statically linked pkgs"}
{-nestedLoadOk "allow nested loading"}
| > > > > | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
interpAddToAccessPath interpFindInAccessPath setLogCmd
####
#
# Setup the arguments parsing
#
####
# Make sure that our temporary variable is local to this
# namespace. [Bug 981733]
variable temp
# Share the descriptions
set temp [::tcl::OptKeyRegister {
{-accessPath -list {} "access path for the slave"}
{-noStatics "prevent loading of statically linked pkgs"}
{-statics true "loading of statically linked pkgs"}
{-nestedLoadOk "allow nested loading"}
|
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
# Helper function to resolve the dual way of specifying staticsok
# (either by -noStatics or -statics 0)
proc InterpStatics {} {
foreach v {Args statics noStatics} {
upvar $v $v
}
set flag [::tcl::OptProcArgGiven -noStatics];
| | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
# Helper function to resolve the dual way of specifying staticsok
# (either by -noStatics or -statics 0)
proc InterpStatics {} {
foreach v {Args statics noStatics} {
upvar $v $v
}
set flag [::tcl::OptProcArgGiven -noStatics];
if {$flag && (!$noStatics == !$statics)
&& ([::tcl::OptProcArgGiven -statics])} {
return -code error\
"conflicting values given for -statics and -noStatics"
}
if {$flag} {
return [expr {!$noStatics}]
} else {
return $statics
}
}
# Helper function to resolve the dual way of specifying nested loading
# (either by -nestedLoadOk or -nested 1)
proc InterpNested {} {
foreach v {Args nested nestedLoadOk} {
upvar $v $v
}
set flag [::tcl::OptProcArgGiven -nestedLoadOk];
# note that the test here is the opposite of the "InterpStatics"
# one (it is not -noNested... because of the wanted default value)
if {$flag && (!$nestedLoadOk != !$nested)
&& ([::tcl::OptProcArgGiven -nested])} {
return -code error\
"conflicting values given for -nested and -nestedLoadOk"
}
if {$flag} {
# another difference with "InterpStatics"
return $nestedLoadOk
|
| ︙ | ︙ | |||
316 317 318 319 320 321 322 |
# you probably need to call "auto_reset" in the slave in order that it
# gets the right auto_index() array values.
proc ::safe::InterpSetConfig {slave access_path staticsok\
nestedok deletehook} {
# determine and store the access path if empty
| | | | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 |
# you probably need to call "auto_reset" in the slave in order that it
# gets the right auto_index() array values.
proc ::safe::InterpSetConfig {slave access_path staticsok\
nestedok deletehook} {
# determine and store the access path if empty
if {$access_path eq ""} {
set access_path [uplevel \#0 set auto_path]
# Make sure that tcl_library is in auto_path
# and at the first position (needed by setAccessPath)
set where [lsearch -exact $access_path [info library]]
if {$where == -1} {
# not found, add it.
set access_path [concat [list [info library]] $access_path]
Log $slave "tcl_library was not in auto_path,\
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
}
# Run some code at the namespace toplevel
proc Toplevel {args} {
namespace eval [namespace current] $args
}
# set/get values
proc Set {args} {
| | | | | 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
}
# Run some code at the namespace toplevel
proc Toplevel {args} {
namespace eval [namespace current] $args
}
# set/get values
proc Set {args} {
eval [linsert $args 0 Toplevel set]
}
# lappend on toplevel vars
proc Lappend {args} {
eval [linsert $args 0 Toplevel lappend]
}
# unset a var/token (currently just an global level eval)
proc Unset {args} {
eval [linsert $args 0 Toplevel unset]
}
# test existance
proc Exists {varname} {
Toplevel info exists $varname
}
# short cut for access path getting
proc GetAccessPath {slave} {
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 |
# package name (can be empty if file is not).
set package [lindex $args 0]
# Determine where to load. load use a relative interp path
# and {} means self, so we can directly and safely use passed arg.
set target [lindex $args 1]
| | | | | 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
# package name (can be empty if file is not).
set package [lindex $args 0]
# Determine where to load. load use a relative interp path
# and {} means self, so we can directly and safely use passed arg.
set target [lindex $args 1]
if {$target ne ""} {
# we will try to load into a sub sub interp
# check that we want to authorize that.
if {![NestedOk $slave]} {
Log $slave "loading to a sub interp (nestedok)\
disabled (trying to load $package to $target)"
return -code error "permission denied (nested load)"
}
}
# Determine what kind of load is requested
if {$file eq ""} {
# static package loading
if {$package eq ""} {
set msg "load error: empty filename and no package name"
Log $slave $msg
return -code error $msg
}
if {![StaticsOk $slave]} {
Log $slave "static packages loading disabled\
(trying to load $package to $target)"
|
| ︙ | ︙ | |||
833 834 835 836 837 838 839 |
set access_path [GetAccessPath $slave]
if {[file isdirectory $file]} {
error "\"$file\": is a directory"
}
set parent [file dirname $file]
| > > > > > > > > | | | 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 |
set access_path [GetAccessPath $slave]
if {[file isdirectory $file]} {
error "\"$file\": is a directory"
}
set parent [file dirname $file]
# Normalize paths for comparison since lsearch knows nothing of
# potential pathname anomalies.
set norm_parent [file normalize $parent]
foreach path $access_path {
lappend norm_access_path [file normalize $path]
}
if {[lsearch -exact $norm_access_path $norm_parent] == -1} {
error "\"$file\": not in access_path"
}
}
# This procedure enables access from a safe interpreter to only a subset of
# the subcommands of a command:
proc Subset {slave command okpat args} {
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
return [eval [linsert $args 0 $command]]
}
set msg "not allowed to invoke subcommand $subcommand of $command"
Log $slave $msg
error $msg
}
# This procedure installs an alias in a slave that invokes "safesubset"
|
| ︙ | ︙ | |||
879 880 881 882 883 884 885 |
set argc [llength $args]
set okpat "^(name.*|convert.*)\$"
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
| > | < | | 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
set argc [llength $args]
set okpat "^(name.*|convert.*)\$"
set subcommand [lindex $args 0]
if {[regexp $okpat $subcommand]} {
return [eval [linsert $args 0 \
::interp invokehidden $slave encoding]]
}
if {[string first $subcommand system] == 0} {
if {$argc == 1} {
# passed all the tests , lets source it:
if {[catch {::interp invokehidden \
$slave encoding system} msg]} {
Log $slave $msg
return -code error "script error"
}
|
| ︙ | ︙ |
Changes to library/tcltest/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.3]} {return}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.3]} {return}
package ifneeded tcltest 2.2.8 [list source [file join $dir tcltest.tcl]]
|
Changes to library/tcltest/tcltest.tcl.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. # | | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
#
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2000 by Ajuba Solutions
# Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
# All rights reserved.
#
# RCS: @(#) $Id: tcltest.tcl,v 1.78.2.13 2005/02/24 18:03:36 dgp Exp $
package require Tcl 8.3 ;# uses [glob -directory]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.2.8
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable patchLevel [info patchlevel]
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 |
proc IsVerbose {level} {
variable Option
return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
}
# Default verbosity is to show bodies of failed tests
| | | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 |
proc IsVerbose {level} {
variable Option
return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
}
# Default verbosity is to show bodies of failed tests
Option -verbose {body error} {
Takes any combination of the values 'p', 's', 'b', 't' and 'e'.
Test suite will display all passed tests if 'p' is specified, all
skipped tests if 's' is specified, the bodies of failed tests if
'b' is specified, and when tests start if 't' is specified.
ErrorInfo is displayed if 'e' is specified.
} AcceptVerbose verbose
|
| ︙ | ︙ | |||
1415 1416 1417 1418 1419 1420 1421 |
exit 1
}
if {[llength $flagArray] == 0} {
RemoveAutoConfigureTraces
} else {
set args $flagArray
| | | > > > > > > | | > | 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 |
exit 1
}
if {[llength $flagArray] == 0} {
RemoveAutoConfigureTraces
} else {
set args $flagArray
while {[llength $args]>1 && [catch {eval configure $args} msg]} {
# Something went wrong parsing $args for tcltest options
# Check whether the problem is "unknown option"
if {[regexp {^unknown option (\S+):} $msg -> option]} {
# Could be this is an option the Hook knows about
set moreOptions [processCmdLineArgsAddFlagsHook]
if {[lsearch -exact $moreOptions $option] == -1} {
# Nope. Report the error, including additional options,
# but keep going
if {[llength $moreOptions]} {
append msg ", "
append msg [join [lrange $moreOptions 0 end-1] ", "]
append msg "or [lindex $moreOptions end]"
}
Warn $msg
}
} else {
# error is something other than "unknown option"
# notify user of the error; and exit
puts [errorChannel] $msg
exit 1
}
# To recover, find that unknown option and remove up to it.
# then retry
while {![string equal [lindex $args 0] $option]} {
set args [lrange $args 2 end]
}
set args [lrange $args 2 end]
}
if {[llength $args] == 1} {
puts [errorChannel] \
"missing value for option [lindex $args 0]"
exit 1
}
}
# Call the hook
catch {
array set flag $flagArray
processCmdLineArgsHook [array get flag]
}
return
}
# tcltest::ProcessCmdLineArgs --
#
# This procedure must be run after constraint initialization is
# set up (by [DefineConstraintInitializers]) because some constraints
|
| ︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 |
# Spit out everything you know if we're at a debug level 2 or
# greater
DebugPuts 2 "Flags passed into tcltest:"
if {[info exists ::env(TCLTEST_OPTIONS)]} {
DebugPuts 2 \
" ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
}
| | | | 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 |
# Spit out everything you know if we're at a debug level 2 or
# greater
DebugPuts 2 "Flags passed into tcltest:"
if {[info exists ::env(TCLTEST_OPTIONS)]} {
DebugPuts 2 \
" ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
}
if {[info exists ::argv]} {
DebugPuts 2 " argv: $::argv"
}
DebugPuts 2 "tcltest::debug = [debug]"
DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]"
DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]"
DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]"
DebugPuts 2 "tcltest::outputChannel = [outputChannel]"
DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
|
| ︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 |
proc tcltest::Eval {script {ignoreOutput 1}} {
variable outData
variable errData
DebugPuts 3 "[lindex [info level 0] 0] called"
if {!$ignoreOutput} {
set outData {}
set errData {}
| < < < < | < | < | | < | < < < | 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
proc tcltest::Eval {script {ignoreOutput 1}} {
variable outData
variable errData
DebugPuts 3 "[lindex [info level 0] 0] called"
if {!$ignoreOutput} {
set outData {}
set errData {}
rename ::puts [namespace current]::Replace::Puts
namespace eval :: \
[list namespace import [namespace origin Replace::puts]]
namespace import Replace::puts
}
set result [uplevel 1 $script]
if {!$ignoreOutput} {
namespace forget puts
namespace eval :: namespace forget puts
rename [namespace current]::Replace::Puts ::puts
}
return $result
}
# tcltest::CompareStrings --
#
# compares the expected answer to the actual answer, depending on
|
| ︙ | ︙ | |||
1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 |
#
proc tcltest::test {name description args} {
global tcl_platform
variable testLevel
variable coreModTime
DebugPuts 3 "test $name $args"
FillFilesExisted
incr testLevel
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
| > > > > > > > | 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 |
#
proc tcltest::test {name description args} {
global tcl_platform
variable testLevel
variable coreModTime
DebugPuts 3 "test $name $args"
DebugDo 1 {
variable TestNames
catch {
puts "test name '$name' re-used; prior use in $TestNames($name)"
}
set TestNames($name) [info script]
}
FillFilesExisted
incr testLevel
# Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not
# these variables (output & errorOutput) are defined.
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 | set values [join [lrange $sorted 0 end-1] ", "] append values ", or [lindex $sorted end]" return -code error "bad -match value \"$match\":\ must be $values" } # Replace symbolic valies supplied for -returnCodes | < | | < < > | 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 |
set values [join [lrange $sorted 0 end-1] ", "]
append values ", or [lindex $sorted end]"
return -code error "bad -match value \"$match\":\
must be $values"
}
# Replace symbolic valies supplied for -returnCodes
foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
}
} else {
# This is parsing for the old test command format; it is here
# for backward compatibility.
set result [lindex $args end]
if {[llength $args] == 2} {
set body [lindex $args 0]
} elseif {[llength $args] == 3} {
|
| ︙ | ︙ | |||
1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 |
if {[file exists [file join [workingDirectory] core]]} {
set coreModTime [file mtime [file join [workingDirectory] core]]
}
}
# First, run the setup script
set code [catch {uplevel 1 $setup} setupMsg]
set setupFailure [expr {$code != 0}]
# Only run the test body if the setup was successful
if {!$setupFailure} {
# Verbose notification of $body start
if {[IsVerbose start]} {
puts [outputChannel] "---- $name start"
flush [outputChannel]
}
set command [list [namespace origin RunTest] $name $body]
if {[info exists output] || [info exists errorOutput]} {
set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
foreach {actualAnswer returnCode} $testResult break
}
# Always run the cleanup script
set code [catch {uplevel 1 $cleanup} cleanupMsg]
set cleanupFailure [expr {$code != 0}]
set coreFailure 0
set coreMsg ""
# check for a core file first - if one was created by the test,
# then the test failed
if {[preserveCore]} {
| > > > > > > > > > > > > | 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 |
if {[file exists [file join [workingDirectory] core]]} {
set coreModTime [file mtime [file join [workingDirectory] core]]
}
}
# First, run the setup script
set code [catch {uplevel 1 $setup} setupMsg]
if {$code == 1} {
set errorInfo(setup) $::errorInfo
set errorCode(setup) $::errorCode
}
set setupFailure [expr {$code != 0}]
# Only run the test body if the setup was successful
if {!$setupFailure} {
# Verbose notification of $body start
if {[IsVerbose start]} {
puts [outputChannel] "---- $name start"
flush [outputChannel]
}
set command [list [namespace origin RunTest] $name $body]
if {[info exists output] || [info exists errorOutput]} {
set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
foreach {actualAnswer returnCode} $testResult break
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCode(body) $::errorCode
}
}
# Always run the cleanup script
set code [catch {uplevel 1 $cleanup} cleanupMsg]
if {$code == 1} {
set errorInfo(cleanup) $::errorInfo
set errorCode(cleanup) $::errorCode
}
set cleanupFailure [expr {$code != 0}]
set coreFailure 0
set coreMsg ""
# check for a core file first - if one was created by the test,
# then the test failed
if {[preserveCore]} {
|
| ︙ | ︙ | |||
1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 |
if {[string length $msg] > 0} {
append coreMsg "\nError:\
Problem renaming core file: $msg"
}
}
}
}
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
set outputFailure 0
variable outData
| > > > > > > | | < < < < < < | | 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 |
if {[string length $msg] > 0} {
append coreMsg "\nError:\
Problem renaming core file: $msg"
}
}
}
}
# check if the return code matched the expected return code
set codeFailure 0
if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
set codeFailure 1
}
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
set outputFailure 0
variable outData
if {[info exists output] && !$codeFailure} {
if {[set outputCompare [catch {
CompareStrings $outData $output $match
} outputMatch]] == 0} {
set outputFailure [expr {!$outputMatch}]
} else {
set outputFailure 1
}
}
set errorFailure 0
variable errData
if {[info exists errorOutput] && !$codeFailure} {
if {[set errorCompare [catch {
CompareStrings $errData $errorOutput $match
} errorMatch]] == 0} {
set errorFailure [expr {!$errorMatch}]
} else {
set errorFailure 1
}
}
# check if the answer matched the expected answer
# Only check if we ran the body of the test (no setup failure)
if {$setupFailure || $codeFailure} {
set scriptFailure 0
} elseif {[set scriptCompare [catch {
CompareStrings $actualAnswer $result $match
} scriptMatch]] == 0} {
set scriptFailure [expr {!$scriptMatch}]
} else {
set scriptFailure 1
|
| ︙ | ︙ | |||
2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 |
if {[string length $body]} {
puts [outputChannel] "==== Contents of test case:"
puts [outputChannel] $body
}
if {$setupFailure} {
puts [outputChannel] "---- Test setup\
failed:\n$setupMsg"
}
if {$scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
puts [outputChannel] "---- Result was:\n$actualAnswer"
puts [outputChannel] "---- Result should have been\
| > > > > | 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 |
if {[string length $body]} {
puts [outputChannel] "==== Contents of test case:"
puts [outputChannel] $body
}
if {$setupFailure} {
puts [outputChannel] "---- Test setup\
failed:\n$setupMsg"
if {[info exists errorInfo(setup)]} {
puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
}
}
if {$scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
puts [outputChannel] "---- Result was:\n$actualAnswer"
puts [outputChannel] "---- Result should have been\
|
| ︙ | ︙ | |||
2101 2102 2103 2104 2105 2106 2107 |
4 { set msg "Test generated continue exception" }
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $returnCode"
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
| | | | | 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 |
4 { set msg "Test generated continue exception" }
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $returnCode"
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
puts [outputChannel] "---- errorInfo: $errorInfo(body)"
puts [outputChannel] "---- errorCode: $errorCode(body)"
}
}
}
if {$outputFailure} {
if {$outputCompare} {
puts [outputChannel] "---- Error testing output: $outputMatch"
} else {
|
| ︙ | ︙ | |||
2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 |
puts [outputChannel] "---- Error output was:\n$errData"
puts [outputChannel] "---- Error output should have\
been ($match matching):\n$errorOutput"
}
}
if {$cleanupFailure} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
}
if {$coreFailure} {
puts [outputChannel] "---- Core file produced while running\
test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
| > > > > | 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 |
puts [outputChannel] "---- Error output was:\n$errData"
puts [outputChannel] "---- Error output should have\
been ($match matching):\n$errorOutput"
}
}
if {$cleanupFailure} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
if {[info exists errorInfo(cleanup)]} {
puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
}
}
if {$coreFailure} {
puts [outputChannel] "---- Core file produced while running\
test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
|
| ︙ | ︙ | |||
2414 2415 2416 2417 2418 2419 2420 |
}
} else {
# if we're deferring stat-reporting until all files are sourced,
# then add current file to failFile list if any tests in this
# file failed
| < | 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 |
}
} else {
# if we're deferring stat-reporting until all files are sourced,
# then add current file to failFile list if any tests in this
# file failed
if {$currentFailure \
&& ([lsearch -exact $failFiles $testFileName] == -1)} {
lappend failFiles $testFileName
}
set currentFailure false
# restore the environment to the state it was in before this package
|
| ︙ | ︙ | |||
2475 2476 2477 2478 2479 2480 2481 |
}
if {[file exists [file join [workingDirectory] core]]} {
if {[preserveCore] > 1} {
puts "rename core file (> 1)"
puts [outputChannel] "produced core file! \
Moving file to: \
| | | | 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 |
}
if {[file exists [file join [workingDirectory] core]]} {
if {[preserveCore] > 1} {
puts "rename core file (> 1)"
puts [outputChannel] "produced core file! \
Moving file to: \
[file join [temporaryDirectory] core-$testFileName]"
catch {file rename -force \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$testFileName]
} msg
if {[string length $msg] > 0} {
PrintError "Problem renaming file: $msg"
}
} else {
# Print a message if there is a core file and (1) there
# previously wasn't one or (2) the new one is different
|
| ︙ | ︙ | |||
2544 2545 2546 2547 2548 2549 2550 |
set matchingFiles [list]
foreach directory $dirList {
# List files in $directory that match patterns to run.
set matchFileList [list]
foreach match [matchFiles] {
set matchFileList [concat $matchFileList \
| | > | > | 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 |
set matchingFiles [list]
foreach directory $dirList {
# List files in $directory that match patterns to run.
set matchFileList [list]
foreach match [matchFiles] {
set matchFileList [concat $matchFileList \
[glob -directory $directory -types {b c f p s} \
-nocomplain -- $match]]
}
# List files in $directory that match patterns to skip.
set skipFileList [list]
foreach skip [skipFiles] {
set skipFileList [concat $skipFileList \
[glob -directory $directory -types {b c f p s} \
-nocomplain -- $skip]]
}
# Add to result list all files in match list and not in skip list
foreach file $matchFileList {
if {[lsearch -exact $skipFileList $file] == -1} {
lappend matchingFiles $file
}
|
| ︙ | ︙ | |||
2593 2594 2595 2596 2597 2598 2599 |
proc tcltest::GetMatchingDirectories {rootdir} {
# Determine the skip list first, to avoid [glob]-ing over subdirectories
# we're going to throw away anyway. Be sure we skip the $rootdir if it
# comes up to avoid infinite loops.
set skipDirs [list $rootdir]
foreach pattern [skipDirectories] {
| | | < < < | | | | < | | < | 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 |
proc tcltest::GetMatchingDirectories {rootdir} {
# Determine the skip list first, to avoid [glob]-ing over subdirectories
# we're going to throw away anyway. Be sure we skip the $rootdir if it
# comes up to avoid infinite loops.
set skipDirs [list $rootdir]
foreach pattern [skipDirectories] {
set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
-nocomplain -- $pattern]]
}
# Now step through the matching directories, prune out the skipped ones
# as you go.
set matchDirs [list]
foreach pattern [matchDirectories] {
foreach path [glob -directory $rootdir -types d -nocomplain -- \
$pattern] {
if {[lsearch -exact $skipDirs $path] == -1} {
set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
if {[file exists [file join $path all.tcl]]} {
lappend matchDirs $path
}
}
}
}
if {[llength $matchDirs] == 0} {
DebugPuts 1 "No test directories remain after applying match\
|
| ︙ | ︙ | |||
2878 2879 2880 2881 2882 2883 2884 |
# string with extra newlines removed
#
# Side effects:
# None.
proc tcltest::normalizeMsg {msg} {
regsub "\n$" [string tolower $msg] "" msg
| | < | | 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 |
# string with extra newlines removed
#
# Side effects:
# None.
proc tcltest::normalizeMsg {msg} {
regsub "\n$" [string tolower $msg] "" msg
set msg [string map [list "\n\n" "\n"] $msg]
return [string map [list "\n\}" "\}"] $msg]
}
# tcltest::makeFile --
#
# Create a new file with the name <name>, and write <contents> to it.
#
# If this file hasn't been created via makeFile since the last time
|
| ︙ | ︙ | |||
3284 3285 3286 3287 3288 3289 3290 |
proc ConfigureFromEnvironment {} {
upvar #0 env(TCLTEST_OPTIONS) options
if {[catch {llength $options} msg]} {
Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\
Tcl list: $msg"
return
}
| | | 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 |
proc ConfigureFromEnvironment {} {
upvar #0 env(TCLTEST_OPTIONS) options
if {[catch {llength $options} msg]} {
Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\
Tcl list: $msg"
return
}
if {[llength $::env(TCLTEST_OPTIONS)] % 2} {
Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\
-option value ?-option value ...?"
return
}
if {[catch {eval Configure $::env(TCLTEST_OPTIONS)} msg]} {
Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
return
|
| ︙ | ︙ |
Changes to library/word.tcl.
1 2 3 4 5 6 7 8 9 10 11 12 | # word.tcl -- # # This file defines various procedures for computing word boundaries # in strings. This file is primarily needed so Tk text and entry # widgets behave properly for different platforms. # # Copyright (c) 1996 by Sun Microsystems, Inc. # Copyright (c) 1998 by Scritpics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# word.tcl --
#
# This file defines various procedures for computing word boundaries
# in strings. This file is primarily needed so Tk text and entry
# widgets behave properly for different platforms.
#
# Copyright (c) 1996 by Sun Microsystems, Inc.
# Copyright (c) 1998 by Scritpics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: word.tcl,v 1.7.2.1 2005/07/22 21:59:41 dgp Exp $
# The following variables are used to determine which characters are
# interpreted as white space.
if {$::tcl_platform(platform) eq "windows"} {
# Windows style - any but a unicode space char
set tcl_wordchars "\\S"
set tcl_nonwordchars "\\s"
} else {
# Motif style - any unicode word char (number, letter, or underscore)
set tcl_wordchars "\\w"
set tcl_nonwordchars "\\W"
|
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_wordBreakBefore {str start} {
global tcl_nonwordchars tcl_wordchars
| | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_wordBreakBefore {str start} {
global tcl_nonwordchars tcl_wordchars
if {$start eq "end"} {
set start [string length $str]
}
if {[regexp -indices "^.*($tcl_wordchars$tcl_nonwordchars|$tcl_nonwordchars$tcl_wordchars)" [string range $str 0 $start] result]} {
return [lindex $result 1]
}
return -1
}
|
| ︙ | ︙ | |||
116 117 118 119 120 121 122 |
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfPreviousWord {str start} {
global tcl_nonwordchars tcl_wordchars
| | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
#
# Arguments:
# str - String to search.
# start - Index into string specifying starting point.
proc tcl_startOfPreviousWord {str start} {
global tcl_nonwordchars tcl_wordchars
if {$start eq "end"} {
set start [string length $str]
}
if {[regexp -indices \
"$tcl_nonwordchars*($tcl_wordchars+)$tcl_nonwordchars*\$" \
[string range $str 0 [expr {$start - 1}]] result word]} {
return [lindex $word 0]
}
return -1
}
|
Changes to mac/README.
1 2 | Tcl 8.4 for Macintosh | | > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | Tcl 8.4 for Macintosh RCS: @(#) $Id: README,v 1.17.2.1 2005/12/04 00:50:03 das Exp $ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Note that Tcl on Mac OS Classic is no longer supported and likely no longer compiles, the last release known to work is 8.4.2. The 'mac' source directory and all other Mac Classic code have been removed from Tk 8.5. The Mac OS X port of Tcl can be found in the 'macosx' source directory. The information and URLs below are known to be outdated and incorrect. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1. Introduction --------------- This is the README file for the Macintosh version of the Tcl scripting language. The home page for the Mac/Tcl info is http://www.tcl.tk/software/mac/ |
| ︙ | ︙ |
Changes to mac/tclMacChan.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclMacChan.c * * Channel drivers for Macintosh channels for the * console fds. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclMacChan.c * * Channel drivers for Macintosh channels for the * console fds. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMacChan.c,v 1.21.2.1 2005/01/27 22:53:34 andreas_kupries Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclMacInt.h" #include <Aliases.h> #include <Errors.h> |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 105 106 107 108 109 110 111 | char *buf, int toRead, int *errorCode)); static int FileOutput _ANSI_ARGS_((ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); static int FileSeek _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCode)); static void FileSetupProc _ANSI_ARGS_((ClientData clientData, int flags)); static Tcl_Channel OpenFileChannel _ANSI_ARGS_((CONST char *fileName, int mode, int permissions, int *errorCodePtr)); static int StdIOBlockMode _ANSI_ARGS_((ClientData instanceData, int mode)); static int StdIOClose _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); static int StdIOInput _ANSI_ARGS_((ClientData instanceData, | > > | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | char *buf, int toRead, int *errorCode)); static int FileOutput _ANSI_ARGS_((ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); static int FileSeek _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCode)); static void FileSetupProc _ANSI_ARGS_((ClientData clientData, int flags)); static void FileThreadActionProc _ANSI_ARGS_ (( ClientData instanceData, int action)); static Tcl_Channel OpenFileChannel _ANSI_ARGS_((CONST char *fileName, int mode, int permissions, int *errorCodePtr)); static int StdIOBlockMode _ANSI_ARGS_((ClientData instanceData, int mode)); static int StdIOClose _ANSI_ARGS_((ClientData instanceData, Tcl_Interp *interp)); static int StdIOInput _ANSI_ARGS_((ClientData instanceData, |
| ︙ | ︙ | |||
119 120 121 122 123 124 125 |
/*
* This structure describes the channel type structure for file based IO:
*/
static Tcl_ChannelType consoleChannelType = {
"file", /* Type name. */
| | > > > > > > | < > > > > > > | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
/*
* This structure describes the channel type structure for file based IO:
*/
static Tcl_ChannelType consoleChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
StdIOClose, /* Close proc. */
StdIOInput, /* Input proc. */
StdIOOutput, /* Output proc. */
StdIOSeek, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
CommonWatch, /* Initialize notifier. */
CommonGetHandle /* Get OS handles out of channel. */
NULL, /* close2proc. */
StdIOBlockMode, /* Set blocking/nonblocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
NULL, /* thread actions */
};
/*
* This variable describes the channel type structure for file based IO.
*/
static Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
FileClose, /* Close proc. */
FileInput, /* Input proc. */
FileOutput, /* Output proc. */
FileSeek, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
CommonWatch, /* Initialize notifier. */
CommonGetHandle /* Get OS handles out of channel. */
NULL, /* close2proc. */
FileBlockMode, /* Set blocking/nonblocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
FileThreadActionProc, /* thread actions */
};
/*
* Hack to allow Mac Tk to override the TclGetStdChannels function.
*/
|
| ︙ | ︙ | |||
1208 1209 1210 1211 1212 1213 1214 |
Tcl_SetMaxBlockTime(&blockTime);
}
}
/*
*----------------------------------------------------------------------
*
| | | < | | < | | < | > > > > > | | < < < < < | | | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 |
Tcl_SetMaxBlockTime(&blockTime);
}
}
/*
*----------------------------------------------------------------------
*
* FileThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
FileThreadActionProc (instanceData, action)
ClientData instanceData;
int action;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileState *infoPtr = (FileState *) instanceData;
if (action == TCL_CHANNEL_THREAD_INSERT) {
infoPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = infoPtr;
} else {
FileState **nextPtrPtr;
int removed = 0;
for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == infoPtr) {
(*nextPtrPtr) = infoPtr->nextPtr;
removed = 1;
break;
}
}
/*
* This could happen if the channel was created in one thread
* and then moved to another without updating the thread
* local data in each thread.
*/
if (!removed) {
panic("file info ptr not on thread channel list");
}
}
}
|
Changes to mac/tclMacFile.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclMacFile.c -- * * This file implements the channel drivers for Macintosh * files. It also comtains Macintosh version of other Tcl * functions that deal with the file system. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclMacFile.c -- * * This file implements the channel drivers for Macintosh * files. It also comtains Macintosh version of other Tcl * functions that deal with the file system. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMacFile.c,v 1.27.2.1 2003/10/03 17:45:37 vincentdarley Exp $ */ /* * Note: This code eventually needs to support async I/O. In doing this * we will need to keep track of all current async I/O. If exit to shell * is called - we shouldn't exit until all asyc I/O completes. */ |
| ︙ | ︙ | |||
174 175 176 177 178 179 180 181 182 183 184 185 186 187 |
/* Match a single file directly */
Tcl_StatBuf buf;
CInfoPBRec paramBlock;
FSSpec fileSpec;
if (TclpObjLstat(fileNamePtr, &buf) != 0) {
/* File doesn't exist */
return TCL_OK;
}
if (FspLLocationFromFsPath(fileNamePtr, &fileSpec) == noErr) {
paramBlock.hFileInfo.ioCompletion = NULL;
paramBlock.hFileInfo.ioNamePtr = fileSpec.name;
paramBlock.hFileInfo.ioVRefNum = fileSpec.vRefNum;
| > | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
/* Match a single file directly */
Tcl_StatBuf buf;
CInfoPBRec paramBlock;
FSSpec fileSpec;
if (TclpObjLstat(fileNamePtr, &buf) != 0) {
/* File doesn't exist */
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
if (FspLLocationFromFsPath(fileNamePtr, &fileSpec) == noErr) {
paramBlock.hFileInfo.ioCompletion = NULL;
paramBlock.hFileInfo.ioNamePtr = fileSpec.name;
paramBlock.hFileInfo.ioVRefNum = fileSpec.vRefNum;
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
if ((fnameLen > 1) && (strchr(fname+1, ':') == NULL)) {
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(fname+1, fnameLen-1));
} else {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
}
return TCL_OK;
} else {
char *fname;
int fnameLen, result = TCL_OK;
int baseLength;
CInfoPBRec pb;
OSErr err;
| > | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
if ((fnameLen > 1) && (strchr(fname+1, ':') == NULL)) {
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(fname+1, fnameLen-1));
} else {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
}
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
} else {
char *fname;
int fnameLen, result = TCL_OK;
int baseLength;
CInfoPBRec pb;
OSErr err;
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
Tcl_DStringFree(&fileString);
if (err == noErr) {
err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory);
}
if ((err != noErr) || !isDirectory) {
Tcl_DStringFree(&dsOrig);
return TCL_OK;
}
}
/* Make sure we have a trailing directory delimiter */
if (Tcl_DStringValue(&dsOrig)[baseLength-1] != ':') {
Tcl_DStringAppend(&dsOrig, ":", 1);
| > | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
Tcl_DStringFree(&fileString);
if (err == noErr) {
err = FSpGetDirectoryID(&dirSpec, &dirID, &isDirectory);
}
if ((err != noErr) || !isDirectory) {
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
}
}
/* Make sure we have a trailing directory delimiter */
if (Tcl_DStringValue(&dsOrig)[baseLength-1] != ':') {
Tcl_DStringAppend(&dsOrig, ":", 1);
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 329 330 331 332 333 334 335 |
Tcl_DecrRefCount(tempName);
}
Tcl_DStringFree(&fileString);
itemIndex++;
}
Tcl_DStringFree(&dsOrig);
return result;
}
}
static int
NativeMatchType(
Tcl_Obj *tempName, /* Path to check */
| > | 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 |
Tcl_DecrRefCount(tempName);
}
Tcl_DStringFree(&fileString);
itemIndex++;
}
Tcl_DStringFree(&dsOrig);
Tcl_DecrRefCount(fileNamePtr);
return result;
}
}
static int
NativeMatchType(
Tcl_Obj *tempName, /* Path to check */
|
| ︙ | ︙ | |||
1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 |
return NULL;
}
if (TclpReadlink(Tcl_GetString(transPtr), &ds) != NULL) {
link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
Tcl_IncrRefCount(link);
Tcl_DStringFree(&ds);
}
}
return link;
}
#endif
| > | 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 |
return NULL;
}
if (TclpReadlink(Tcl_GetString(transPtr), &ds) != NULL) {
link = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
Tcl_IncrRefCount(link);
Tcl_DStringFree(&ds);
}
Tcl_DecrRefCount(transPtr);
}
return link;
}
#endif
|
| ︙ | ︙ |
Changes to mac/tclMacInit.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclMacInit.c -- * * Contains the Mac-specific interpreter initialization functions. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclMacInit.c -- * * Contains the Mac-specific interpreter initialization functions. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMacInit.c,v 1.9.2.2 2005/10/23 22:01:31 msofer Exp $ */ #include <AppleEvents.h> #include <AEDataModel.h> #include <AEObjects.h> #include <AEPackObject.h> #include <AERegistry.h> |
| ︙ | ︙ | |||
335 336 337 338 339 340 341 | * encoding. TclpSetInitialEncodings() will translate the library * path from the native encoding to UTF-8 as soon as it determines * what the native encoding actually is. * * Called at process initialization time. * * Results: | > | | | 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
* encoding. TclpSetInitialEncodings() will translate the library
* path from the native encoding to UTF-8 as soon as it determines
* what the native encoding actually is.
*
* Called at process initialization time.
*
* Results:
* Return 1, indicating that the UTF may be dirty and require "cleanup"
* after encodings are initialized.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
TclpInitLibraryPath(argv0)
CONST char *argv0; /* Name of executable from argv[0] to main().
* Not used because we can determine the name
* by querying the module handle. */
{
Tcl_Obj *objPtr, *pathPtr;
CONST char *str;
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&path));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&libPath);
Tcl_DStringFree(&path);
}
TclSetLibraryPath(pathPtr);
}
/*
*---------------------------------------------------------------------------
*
* TclpSetInitialEncodings --
*
| > > | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&path));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
Tcl_DStringFree(&libPath);
Tcl_DStringFree(&path);
}
TclSetLibraryPath(pathPtr);
return 1; /* 1 indicates that pathPtr may be dirty utf (needs cleaning) */
}
/*
*---------------------------------------------------------------------------
*
* TclpSetInitialEncodings --
*
|
| ︙ | ︙ | |||
705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 |
* look in the tcl_library directory. Ditto for the history command.
*/
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
pathPtr = Tcl_NewObj();
}
Tcl_SetVar2Ex(interp, "auto_path", NULL, pathPtr, TCL_GLOBAL_ONLY);
return Tcl_Eval(interp, initCmd);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceRCFile --
| > > | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 |
* look in the tcl_library directory. Ditto for the history command.
*/
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
pathPtr = Tcl_NewObj();
}
Tcl_IncrRefCount(pathPtr);
Tcl_SetVar2Ex(interp, "auto_path", NULL, pathPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(pathPtr);
return Tcl_Eval(interp, initCmd);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceRCFile --
|
| ︙ | ︙ |
Changes to mac/tclMacNotify.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * event proc will have to arbitrate which events go to which threads. * * Copyright (c) 1995-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * event proc will have to arbitrate which events go to which threads. * * Copyright (c) 1995-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMacNotify.c,v 1.8.4.1 2003/03/21 03:24:08 dgp Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclMac.h" #include "tclMacInt.h" #include <signal.h> |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 57 | /* * Need this for replacing Tcl_SetTimer and Tcl_WaitForEvent defined * in THIS file with ones defined in the stub table. */ extern TclStubs tclStubs; /* * The follwing static indicates whether this module has been initialized. */ static int initialized = 0; | > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | /* * Need this for replacing Tcl_SetTimer and Tcl_WaitForEvent defined * in THIS file with ones defined in the stub table. */ extern TclStubs tclStubs; extern Tcl_NotifierProcs tclOriginalNotifier; /* * The follwing static indicates whether this module has been initialized. */ static int initialized = 0; |
| ︙ | ︙ | |||
335 336 337 338 339 340 341 |
Tcl_Time *timePtr) /* New value for interval timer. */
{
/*
* Allow the notifier to be hooked. This may not make sense
* on the Mac, but mirrors the UNIX hook.
*/
| | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
Tcl_Time *timePtr) /* New value for interval timer. */
{
/*
* Allow the notifier to be hooked. This may not make sense
* on the Mac, but mirrors the UNIX hook.
*/
if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
tclStubs.tcl_SetTimer(timePtr);
return;
}
if (!timePtr) {
notifier.timerActive = 0;
} else {
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 |
Rect mouseRect;
/*
* Allow the notifier to be hooked. This may not make
* sense on the Mac, but mirrors the UNIX hook.
*/
| | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 |
Rect mouseRect;
/*
* Allow the notifier to be hooked. This may not make
* sense on the Mac, but mirrors the UNIX hook.
*/
if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
return tclStubs.tcl_WaitForEvent(timePtr);
}
/*
* Compute the next timeout value.
*/
|
| ︙ | ︙ |
Changes to mac/tclMacResource.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclMacResource.c -- * * This file contains several commands that manipulate or use * Macintosh resources. Included are extensions to the "source" * command, the mac specific "beep" and "resource" commands, and * administration for open resource file references. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclMacResource.c -- * * This file contains several commands that manipulate or use * Macintosh resources. Included are extensions to the "source" * command, the mac specific "beep" and "resource" commands, and * administration for open resource file references. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMacResource.c,v 1.14.2.1 2003/10/01 14:34:16 das Exp $ */ #include <Errors.h> #include <FSpCompat.h> #include <Processes.h> #include <Resources.h> #include <Sound.h> |
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 |
} else {
resource = GetNamedResource(resourceType,
rezName);
}
Tcl_DStringFree(&ds);
}
| | | 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 |
} else {
resource = GetNamedResource(resourceType,
rezName);
}
Tcl_DStringFree(&ds);
}
if (resource != NULL && *resource == NULL) {
*releaseIt = 1;
LoadResource(resource);
} else {
*releaseIt = 0;
}
SetResLoad(true);
|
| ︙ | ︙ |
Changes to mac/tclMacSock.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclMacSock.c * * Channel drivers for Macintosh sockets. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclMacSock.c * * Channel drivers for Macintosh sockets. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclMacSock.c,v 1.14.2.1 2006/03/10 14:27:41 vasiljevic Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclMacInt.h" #include <AddressXlation.h> #include <Aliases.h> |
| ︙ | ︙ | |||
155 156 157 158 159 160 161 | static TcpState * NewSocketInfo _ANSI_ARGS_((StreamPtr stream)); static OSErr ResolveAddress _ANSI_ARGS_((ip_addr tcpAddress, Tcl_DString *dsPtr)); static void SocketCheckProc _ANSI_ARGS_((ClientData clientData, int flags)); static int SocketEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); | < | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 | static TcpState * NewSocketInfo _ANSI_ARGS_((StreamPtr stream)); static OSErr ResolveAddress _ANSI_ARGS_((ip_addr tcpAddress, Tcl_DString *dsPtr)); static void SocketCheckProc _ANSI_ARGS_((ClientData clientData, int flags)); static int SocketEventProc _ANSI_ARGS_((Tcl_Event *evPtr, int flags)); static void SocketFreeProc _ANSI_ARGS_((ClientData clientData)); static int SocketReady _ANSI_ARGS_((TcpState *statePtr)); static void SocketSetupProc _ANSI_ARGS_((ClientData clientData, int flags)); static void TcpAccept _ANSI_ARGS_((TcpState *statePtr)); static int TcpBlockMode _ANSI_ARGS_((ClientData instanceData, int mode)); static int TcpClose _ANSI_ARGS_((ClientData instanceData, |
| ︙ | ︙ | |||
363 364 365 366 367 368 369 370 371 |
/*
* Do per-thread initialization.
*/
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr->socketList = NULL;
Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
| > < | | < | | | > | | > | < < | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
/*
* Do per-thread initialization.
*/
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->socketList = NULL;
Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeSockets --
*
* Invoked during exit clean up to deinitialize the socket module.
*
* Results:
* None.
*
* Side effects:
* Removed event source.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeSockets()
{
ThreadSpecificData *tsdPtr;
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TclpHasSockets --
|
| ︙ | ︙ |
Changes to mac/tclMacThrd.c.
| ︙ | ︙ | |||
164 165 166 167 168 169 170 | * The result area is set to the exit code of the thread we * waited upon. * *---------------------------------------------------------------------- */ int | | | | | | | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
* The result area is set to the exit code of the thread we
* waited upon.
*
*----------------------------------------------------------------------
*/
int
Tcl_JoinThread(threadId, result)
Tcl_ThreadId threadId; /* Id of the thread to wait upon */
int* result; /* Reference to the storage the result
* of the thread we wait upon will be
* written into. */
{
if (!TclMacHaveThreads()) {
return TCL_ERROR;
}
return TclJoinThread (threadId, result);
}
/*
*----------------------------------------------------------------------
*
* TclpThreadExit --
*
|
| ︙ | ︙ |
Changes to macosx/Makefile.
|
| | | > | > > > > > | | > > > > | | > > > > | > > > > > > > | > > | > > | > > > > > | > > > > > > > > > > | > > > | > > > | > > > > > > | > < > > > < > > < > > < > > > > | < > < > > > > > > > > > > > > | | > > > < < > < < > > > | < < > > > > > > | < > > | > > > > > > > > > | > | > > > | > | | | | > > > > > > > > > > > > > > > | | | < | < > > > > > > > > > > | > | | | > > < > | < | > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
########################################################################################################
#
# Makefile wrapper to build tcl on Mac OS X in a way compatible with the tk/macosx Xcode buildsystem
# uses the standard unix build system in tcl/unix (which can be used directly instead of this
# if you are not using the tk/macosx projects).
#
# Copyright (c) 2002-2007 Daniel A. Steffen <das@users.sourceforge.net>
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: Makefile,v 1.5.2.17 2007/04/29 02:21:33 das Exp $
#
########################################################################################################
#-------------------------------------------------------------------------------------------------------
# customizable settings
DESTDIR ?=
INSTALL_ROOT ?= ${DESTDIR}
BUILD_DIR ?= ${CURDIR}/../../build
SYMROOT ?= ${BUILD_DIR}/${PROJECT}
OBJROOT ?= ${SYMROOT}
EXTRA_CONFIGURE_ARGS ?=
EXTRA_MAKE_ARGS ?=
INSTALL_PATH ?= /Library/Frameworks
PREFIX ?= /usr/local
BINDIR ?= ${PREFIX}/bin
LIBDIR ?= ${INSTALL_PATH}
MANDIR ?= ${PREFIX}/man
# set to non-empty value to install manpages in addition to html help:
INSTALL_MANPAGES ?=
#-------------------------------------------------------------------------------------------------------
# meta targets
meta := all install embedded install-embedded clean distclean test
styles := develop deploy
all := ${styles}
all : ${all}
install := ${styles:%=install-%}
install : ${install}
install-%: action := install-
embedded := ${styles:%=embedded-%}
embedded : embedded-deploy
install-embedded := ${embedded:%=install-%}
install-embedded : install-embedded-deploy
clean := ${styles:%=clean-%}
clean : ${clean}
clean-%: action := clean-
distclean := ${styles:%=distclean-%}
distclean : ${distclean}
distclean-%: action := distclean-
test := ${styles:%=test-%}
test : ${test}
test-%: action := test-
targets := $(foreach v,${meta},${$v})
#-------------------------------------------------------------------------------------------------------
# build styles
BUILD_STYLE =
CONFIGURE_ARGS =
OBJ_DIR = ${OBJROOT}/${BUILD_STYLE}
develop_make_args := BUILD_STYLE=Development CONFIGURE_ARGS=--enable-symbols
deploy_make_args := BUILD_STYLE=Deployment INSTALL_TARGET=install-strip \
GENERIC_FLAGS=-DNDEBUG
embedded_make_args := EMBEDDED_BUILD=1
install_make_args := INSTALL_BUILD=1
${targets}:
${MAKE} ${action}${PROJECT} \
$(foreach s,${styles} embedded install,$(if $(findstring $s,$@),${${s}_make_args}))
#-------------------------------------------------------------------------------------------------------
# project specific settings
PROJECT := tcl
PRODUCT_NAME := Tcl
UNIX_DIR := ${CURDIR}/../unix
VERSION := $(shell awk -F= '/^TCL_VERSION/ {print $$2; nextfile}' ${UNIX_DIR}/configure.in)
TCLSH := tclsh${VERSION}
BUILD_TARGET := all tcltest
INSTALL_TARGET := install
export CPPROG := cp -p
INSTALL_TARGETS = install-binaries install-libraries
ifeq (${EMBEDDED_BUILD},)
INSTALL_TARGETS += install-private-headers
endif
ifeq (${INSTALL_BUILD}_${EMBEDDED_BUILD}_${BUILD_STYLE},1__Deployment)
INSTALL_TARGETS += html-tcl
ifneq (${INSTALL_MANPAGES},)
INSTALL_TARGETS += install-doc
endif
endif
MAKE_VARS := INSTALL_ROOT INSTALL_TARGETS VERSION GENERIC_FLAGS
MAKE_ARGS_V = $(foreach v,${MAKE_VARS},$v='${$v}')
build-${PROJECT}: target = ${BUILD_TARGET}
install-${PROJECT}: target = ${INSTALL_TARGET}
clean-${PROJECT} distclean-${PROJECT} test-${PROJECT}: \
target = $*
DO_MAKE = +${MAKE} -C ${OBJ_DIR} ${target} ${MAKE_ARGS_V} ${MAKE_ARGS} ${EXTRA_MAKE_ARGS}
#-------------------------------------------------------------------------------------------------------
# build rules
${PROJECT}:
${MAKE} install-${PROJECT} INSTALL_ROOT=${OBJ_DIR}/
${OBJ_DIR}/Makefile: ${UNIX_DIR}/Makefile.in ${UNIX_DIR}/configure \
${UNIX_DIR}/tclConfig.sh.in Tcl-Info.plist.in
mkdir -p ${OBJ_DIR} && cd ${OBJ_DIR} && \
if [ ${UNIX_DIR}/configure -nt config.status ]; then ${UNIX_DIR}/configure \
--prefix=${PREFIX} --bindir=${BINDIR} --libdir=${LIBDIR} \
--mandir=${MANDIR} --enable-threads --enable-framework \
${CONFIGURE_ARGS} ${EXTRA_CONFIGURE_ARGS}; else ./config.status; fi
build-${PROJECT}: ${OBJ_DIR}/Makefile
${DO_MAKE}
ifeq (${INSTALL_BUILD},)
# symolic link hackery to trick
# 'make install INSTALL_ROOT=${OBJ_DIR}'
# into building Tcl.framework and tclsh in ${SYMROOT}
@cd ${OBJ_DIR} && mkdir -p $(dir ./${LIBDIR}) $(dir ./${BINDIR}) ${SYMROOT} && \
rm -f ./${LIBDIR} ./${BINDIR} && ln -fs ${SYMROOT} ./${LIBDIR} && \
ln -fs ${SYMROOT} ./${BINDIR} && ln -fs ${OBJ_DIR}/tcltest ${SYMROOT}
endif
install-${PROJECT}: build-${PROJECT}
ifeq (${EMBEDDED_BUILD}_${INSTALL_ROOT},1_)
@echo "Cannot install-embedded with empty INSTALL_ROOT !" && false
endif
ifeq (${EMBEDDED_BUILD},1)
@rm -rf "${INSTALL_ROOT}/${LIBDIR}/Tcl.framework"
endif
${DO_MAKE}
ifeq (${INSTALL_BUILD},1)
ifeq (${EMBEDDED_BUILD},1)
# if we are embedding frameworks, don't install tclsh
@rm -f "${INSTALL_ROOT}${BINDIR}/${TCLSH}" && \
rmdir -p "${INSTALL_ROOT}${BINDIR}" 2>&- || true
else
# redo prebinding (when not building for Mac OS X 10.4 or later only)
@if [ "`echo "$${MACOSX_DEPLOYMENT_TARGET}" | \
awk -F '10\\.' '{print int($$2)}'`" -lt 4 -a "`echo "$${CFLAGS}" | \
awk -F '-mmacosx-version-min=10\\.' '{print int($$2)}'`" -lt 4 ]; \
then cd ${INSTALL_ROOT}/; \
if [ ! -d usr/lib ]; then mkdir -p usr && ln -fs /usr/lib usr/ && RM_USRLIB=1; fi; \
if [ ! -d System ]; then ln -fs /System . && RM_SYSTEM=1; fi; \
redo_prebinding -r . "./${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION}/${PRODUCT_NAME}"; \
redo_prebinding -r . "./${BINDIR}/${TCLSH}"; \
if [ -n "$${RM_USRLIB:-}" ]; then rm -f usr/lib; rmdir -p usr 2>&-; fi; \
if [ -n "$${RM_SYSTEM:-}" ]; then rm -f System; fi; fi
# install tclsh symbolic link
@ln -fs ${TCLSH} ${INSTALL_ROOT}${BINDIR}/tclsh
endif
endif
ifeq (${BUILD_STYLE}_${EMBEDDED_BUILD},Development_)
# keep copy of debug library around, so that
# Deployment build can be installed on top
# of Development build without overwriting
# the debug library
@cd ${INSTALL_ROOT}${LIBDIR}/${PRODUCT_NAME}.framework/Versions/${VERSION} && \
ln -f "${PRODUCT_NAME}" "${PRODUCT_NAME}_debug"
endif
clean-${PROJECT}: %-${PROJECT}:
${DO_MAKE}
rm -rf ${SYMROOT}/{${PRODUCT_NAME}.framework,${TCLSH},tcltest}
rm -f ${OBJ_DIR}{${LIBDIR},${BINDIR}} && \
rmdir -p ${OBJ_DIR}$(dir ${LIBDIR}) 2>&- || true && \
rmdir -p ${OBJ_DIR}$(dir ${BINDIR}) 2>&- || true
distclean-${PROJECT}: %-${PROJECT}: clean-${PROJECT}
${DO_MAKE}
rm -rf ${OBJ_DIR}
test-${PROJECT}: %-${PROJECT}: build-${PROJECT}
${DO_MAKE}
#-------------------------------------------------------------------------------------------------------
.PHONY: ${meta} ${targets} ${PROJECT} build-${PROJECT} install-${PROJECT} \
clean-${PROJECT} distclean-${PROJECT}
.NOTPARALLEL:
#-------------------------------------------------------------------------------------------------------
|
Added macosx/README.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
Tcl Mac OS X README
-------------------
RCS: @(#) $Id: README,v 1.1.2.9 2007/04/29 02:21:33 das Exp $
This is the README file for the Mac OS X/Darwin version of Tcl.
1. Where to go for support
--------------------------
- The tcl-mac mailing list on sourceforge is the best place to ask questions
specific to Tcl & Tk on Mac OS X:
http://lists.sourceforge.net/lists/listinfo/tcl-mac
(this page also has a link to searchable archives of the list, please check them
before asking on the list, many questions have already been answered).
- For general Tcl/Tk questions, the newsgroup comp.lang.tcl is your best bet:
http://groups.google.com/group/comp.lang.tcl/
- The Tcl'ers Wiki also has many pages dealing with Tcl & Tk on Mac OS X, see
http://wiki.tcl.tk/references/3753!
http://wiki.tcl.tk/references/8361!
- Please report bugs with Tcl or Tk on Mac OS X to the sourceforge bug trackers:
Tcl: http://sf.net/tracker/?func=add&group_id=10894&atid=110894
Tk: http://sf.net/tracker/?func=add&group_id=12997&atid=112997
please make sure that your report Tk specific bugs to the tktoolkit project bug
tracker rather than the tcl project bug tracker.
Mac OS X specific bugs should usually be assigned to 'das' or 'wolfsuit'.
2. Using Tcl on Mac OS X
------------------------
- At a minimum, Mac OS X 10.1 is required to run Tcl, but OS X 10.3 or higher is
recommended (certain [file] operations behave incorrectly on earlier releases).
- Unless weak-linking is used, Tcl built on Mac OS X 10.x will not run on 10.y
with y < x; on the other hand Tcl built on 10.y will always run on 10.x with
y <= x (but without any of the fixes and optimizations that would be available
in a binary built on 10.x).
Weak-linking is available on OS X 10.2 or later, it additionally allows Tcl
built on 10.x to run on any 10.y with x > y >= z (for a chosen z >= 2).
- Tcl extensions can be installed in any of:
$HOME/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl
$HOME/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks
/System/Library/Frameworks (searched in that order).
Given a potential package directory $pkg, Tcl on OSX checks for the file
$pkg/Resources/Scripts/pkgIndex.tcl as well as the usual $pkg/pkgIndex.tcl.
This allows building extensions as frameworks with all script files contained in
the Resources/Scripts directory of the framework.
- [load]able binary extensions can linked as either ordinary shared libraries
(.dylib) or as MachO bundles (since 8.4.10/8.5a3); only bundles can be unloaded,
and bundles are also loaded more efficiently from VFS (no temporary copy to the
native filesystem required).
- The 'deploy' target of macosx/Makefile installs the html manpages into the
standard documentation location in the Tcl framework:
Tcl.framework/Resources/Documentation/Reference/Tcl
No nroff manpages are installed by default by the Makefile.
- The Tcl framework can be installed in any of the system's standard
framework directories:
$HOME/Library/Frameworks /Library/Frameworks
/Network/Library/Frameworks /System/Library/Frameworks
3. Building Tcl on Mac OS X
---------------------------
- At least Mac OS X 10.1 is required to build Tcl, and Apple's Developer Tools
need to be installed (only the most recent version matching your OS release is
supported). The Developer Tools installer is available on Mac OS X retail disks
or is present in /Applications/Installers on Macs that came with OS X
preinstalled. The most recent version can be downloaded from the ADC website
http://connect.apple.com (after you register for free ADC membership).
- Tcl is most easily built as a Mac OS X framework via Makefile in tcl/macosx
(see below for details), but can also be built with the standard unix configure
and make buildsystem in tcl/unix as on any other unix platform (indeed, the
Makefile is just a wrapper around the unix buildsystem).
The Mac OS X specific configure flags are --enable-framework and
--disable-corefoundation (which disables CF and notably reverts to the standard
select based notifier).
- It is also possible to build with Apple's IDE via the tcl/macosx/Tcl.pbproj
project, this simply calls through to the tcl/macosx/Makefile.
- To build universal binaries, set CFLAGS as follows:
export CFLAGS="-arch ppc -arch ppc64 -arch i386 -arch x86_64 \
-isysroot /Developer/SDKs/MacOSX10.4u.sdk -mmacosx-version-min=10.4"
This requires Mac OS X 10.4 and Xcode 2.4 (or Xcode 2.2 if -arch x86_64 is
omitted, but _not_ Xcode 2.1) and will work on any of the architectures (the
-isysroot flag is only required on PowerPC Tiger).
Note that configure requires CFLAGS to contain a least one architecture that can
be run on the build machine (i.e. ppc on G3/G4, ppc or ppc64 on G5, ppc or i386
on Core and ppc, i386 or x86_64 on Core2/Xeon).
Universal builds of Tcl TEA extensions are also possible with CFLAGS set as
above, they will be [load]able by universal as well as thin binaries of Tcl.
- To enable weak-linking, set the MACOSX_DEPLOYMENT_TARGET environment variable
to the minimal OS version (>= 10.2) the binaries should be able to run on, e.g:
export MACOSX_DEPLOYMENT_TARGET=10.2
This requires Mac OS X 10.2 and gcc 3.1; if you have gcc 4 or later you can set
CFLAGS instead:
export CFLAGS="-mmacosx-version-min=10.2"
Support for weak-linking was added to the code for 8.4.14/8.5a5.
Detailed Instructions for building with macosx/Makefile
-------------------------------------------------------
- Unpack the tcl source release archive.
- The following instructions assume the tcl source tree is named "tcl${ver}",
where ${ver} is a shell variable containing the tcl version number (for example
'8.4.12').
Setup the shell variable as follows:
set ver="8.4.12" ;: if your shell is csh
ver="8.4.12" ;: if your shell is sh
The source tree will be named this way only if you are building from a release
archive, if you are building from CVS, the version numbers will be missing; so
set ${ver} to the empty string instead:
set ver="" ;: if your shell is csh
ver="" ;: if your shell is sh
- The following steps will build Tcl from the Terminal, assuming you are located
in the directory containing the tcl source tree:
make -C tcl${ver}/macosx
and the following will then install Tcl onto the root volume (admin password
required):
sudo make -C tcl${ver}/macosx install
if you don't have the admin password, you can install into your home directory,
instead by passing an INSTALL_ROOT argument to make:
make -C tcl${ver}/macosx install INSTALL_ROOT="${HOME}/"
- The default Makefile targets will build _both_ debug and optimized versions of
the Tcl framework with the standard convention of naming the debug library
Tcl.framework/Tcl_debug.
This allows switching to the debug libraries at runtime by setting
export DYLD_IMAGE_SUFFIX=_debug
(c.f. man dyld for more details)
If you only want to build and install the debug or optimized build, use the
'develop' or 'deploy' target variants of the Makefiles, respectively.
For example, to build and install only the optimized versions:
make -C tcl${ver}/macosx deploy
sudo make -C tcl${ver}/macosx install-deploy
|
Added macosx/Tcl-Info.plist.in.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!-- Copyright (c) 2005-2007 Daniel A. Steffen <das@users.sourceforge.net> See the file "license.terms" for information on usage and redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. RCS: @(#) $Id: Tcl-Info.plist.in,v 1.1.2.3 2007/04/29 02:21:33 das Exp $ --> <plist version="1.0"> <dict> <key>CFBundleDevelopmentRegion</key> <string>English</string> <key>CFBundleExecutable</key> <string>@TCL_LIB_FILE@</string> <key>CFBundleGetInfoString</key> <string>Tcl @TCL_VERSION@@TCL_PATCH_LEVEL@, Copyright © @TCL_YEAR@ Tcl Core Team, Copyright © 2001-@TCL_YEAR@ Daniel A. Steffen, Initial MacOS X Port by Jim Ingham & Ian Reid, Copyright © 2001-2002, Apple Computer, Inc.</string> <key>CFBundleIdentifier</key> <string>com.tcltk.tcllibrary</string> <key>CFBundleInfoDictionaryVersion</key> <string>6.0</string> <key>CFBundleName</key> <string>Tcl @TCL_VERSION@</string> <key>CFBundlePackageType</key> <string>FMWK</string> <key>CFBundleShortVersionString</key> <string>@TCL_VERSION@@TCL_PATCH_LEVEL@</string> <key>CFBundleSignature</key> <string>Tcl </string> <key>CFBundleVersion</key> <string>@TCL_VERSION@@TCL_PATCH_LEVEL@</string> </dict> </plist> |
Added macosx/Tcl.pbproj/default.pbxuser.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
// !$*UTF8*$!
{
00E2F845016E82EB0ACA28DC = {
activeBuildStyle = 00E2F847016E82EB0ACA28DC;
activeExecutable = F594E5F1030774B1016F146B;
activeTarget = 00E2F84C016E8B780ACA28DC;
addToTargets = (
);
codeSenseManager = F9D167E40610239A0027C147;
executables = (
F53ACC52031D9AFE016F146B,
F594E5F1030774B1016F146B,
);
sourceControlManager = F9D167E30610239A0027C147;
userBuildSettings = {
SYMROOT = "${SRCROOT}/../../build/tcl";
};
};
00E2F84C016E8B780ACA28DC = {
activeExec = 0;
};
F53ACC52031D9AFE016F146B = {
activeArgIndex = 2147483647;
activeArgIndices = (
NO,
NO,
);
argumentStrings = (
"${SRCROOT}/../../tcl/tests/all.tcl",
"-verbose \"\"",
);
configStateDict = {
"PBXLSLaunchAction-0" = {
PBXLSLaunchAction = 0;
PBXLSLaunchStartAction = 1;
PBXLSLaunchStdioStyle = 2;
PBXLSLaunchStyle = 0;
class = PBXLSRunLaunchConfig;
displayName = "Executable Runner";
identifier = com.apple.Xcode.launch.runConfig;
remoteHostInfo = "";
startActionInfo = "";
};
"PBXLSLaunchAction-1" = {
PBXLSLaunchAction = 1;
PBXLSLaunchStartAction = 1;
PBXLSLaunchStdioStyle = 2;
PBXLSLaunchStyle = 0;
class = PBXGDB_LaunchConfig;
displayName = GDB;
identifier = com.apple.Xcode.launch.GDBMI_Config;
remoteHostInfo = "";
startActionInfo = "";
};
};
cppStopOnCatchEnabled = 0;
cppStopOnThrowEnabled = 0;
customDataFormattersEnabled = 1;
debuggerPlugin = GDBDebugging;
disassemblyDisplayState = 0;
dylibVariantSuffix = _debug;
enableDebugStr = 0;
environmentEntries = (
{
active = YES;
name = TCL_LIBRARY;
value = "${SRCROOT}/../../tcl/library";
},
{
active = NO;
name = DYLD_PRINT_LIBRARIES;
},
);
isa = PBXExecutable;
launchableReference = F5C37CF303D5BEDF016F146B;
libgmallocEnabled = 0;
name = tcltest;
shlibInfoDictList = (
);
sourceDirectories = (
);
startupPath = "<<ProductDirectory>>";
};
F594E5F1030774B1016F146B = {
activeArgIndex = 2147483647;
activeArgIndices = (
);
argumentStrings = (
);
configStateDict = {
"PBXLSLaunchAction-0" = {
PBXLSLaunchAction = 0;
PBXLSLaunchStartAction = 1;
PBXLSLaunchStdioStyle = 2;
PBXLSLaunchStyle = 0;
class = PBXLSRunLaunchConfig;
displayName = "Executable Runner";
identifier = com.apple.Xcode.launch.runConfig;
remoteHostInfo = "";
startActionInfo = "";
};
"PBXLSLaunchAction-1" = {
PBXLSLaunchAction = 1;
PBXLSLaunchStartAction = 1;
PBXLSLaunchStdioStyle = 2;
PBXLSLaunchStyle = 0;
class = PBXGDB_LaunchConfig;
displayName = GDB;
identifier = com.apple.Xcode.launch.GDBMI_Config;
remoteHostInfo = "";
startActionInfo = "";
};
};
cppStopOnCatchEnabled = 0;
cppStopOnThrowEnabled = 0;
customDataFormattersEnabled = 1;
debuggerPlugin = GDBDebugging;
disassemblyDisplayState = 0;
dylibVariantSuffix = _debug;
enableDebugStr = 0;
environmentEntries = (
{
active = NO;
name = DYLD_PRINT_LIBRARIES;
},
);
isa = PBXExecutable;
launchableReference = F98F02E608E7EF9A00D0320A;
libgmallocEnabled = 0;
name = tclsh;
shlibInfoDictList = (
);
sourceDirectories = (
);
startupPath = "<<ProductDirectory>>";
};
F5C37CF303D5BEDF016F146B = {
isa = PBXFileReference;
lastKnownFileType = "compiled.mach-o.executable";
path = tcltest;
refType = 3;
sourceTree = BUILT_PRODUCTS_DIR;
};
F98F02E608E7EF9A00D0320A = {
isa = PBXFileReference;
lastKnownFileType = "compiled.mach-o.executable";
path = tclsh8.4;
refType = 3;
sourceTree = BUILT_PRODUCTS_DIR;
};
F9D167E30610239A0027C147 = {
fallbackIsa = XCSourceControlManager;
isSCMEnabled = 0;
isa = PBXSourceControlManager;
scmConfiguration = {
};
scmType = scm.cvs;
};
F9D167E40610239A0027C147 = {
indexTemplatePath = "";
isa = PBXCodeSenseManager;
usesDefaults = 1;
wantsCodeCompletion = 1;
wantsCodeCompletionAutoSuggestions = 1;
wantsCodeCompletionCaseSensitivity = 1;
wantsCodeCompletionListAlways = 1;
wantsCodeCompletionOnlyMatchingItems = 1;
wantsCodeCompletionParametersIncluded = 1;
wantsCodeCompletionPlaceholdersInserted = 1;
wantsCodeCompletionTabCompletes = 1;
wantsIndex = 1;
};
}
|
Changes to macosx/Tcl.pbproj/jingham.pbxuser.
1 2 |
// !$*UTF8*$!
{
| < < < < < < < < < < < < < < < < > | < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | > > > > > > > > > > > > > > > > > > | | > > > | | | > | | > > | > > | > > > > > | > > | > | > > > | > > | > > | > | | > | < > > > | | > > > > | | > > > > > | > > | > | > | | | > > > > > > > | | > | | > > | > | | | > | > > | < | | | < | | < | | | | > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
// !$*UTF8*$!
{
00E2F845016E82EB0ACA28DC = {
activeBuildStyle = 00E2F847016E82EB0ACA28DC;
activeExecutable = F594E5F1030774B1016F146B;
activeTarget = 00E2F84C016E8B780ACA28DC;
addToTargets = (
);
codeSenseManager = F9D167E40610239A0027C147;
executables = (
F53ACC52031D9AFE016F146B,
F594E5F1030774B1016F146B,
);
sourceControlManager = F9D167E30610239A0027C147;
userBuildSettings = {
SYMROOT = "${SRCROOT}/../../build/tcl";
};
};
00E2F84C016E8B780ACA28DC = {
activeExec = 0;
};
F53ACC52031D9AFE016F146B = {
activeArgIndex = 2147483647;
activeArgIndices = (
NO,
NO,
);
argumentStrings = (
"${SRCROOT}/../../tcl/tests/all.tcl",
"-verbose \"\"",
);
configStateDict = {
"PBXLSLaunchAction-0" = {
PBXLSLaunchAction = 0;
PBXLSLaunchStartAction = 1;
PBXLSLaunchStdioStyle = 2;
PBXLSLaunchStyle = 0;
class = PBXLSRunLaunchConfig;
displayName = "Executable Runner";
identifier = com.apple.Xcode.launch.runConfig;
remoteHostInfo = "";
startActionInfo = "";
};
"PBXLSLaunchAction-1" = {
PBXLSLaunchAction = 1;
PBXLSLaunchStartAction = 1;
PBXLSLaunchStdioStyle = 2;
PBXLSLaunchStyle = 0;
class = PBXGDB_LaunchConfig;
displayName = GDB;
identifier = com.apple.Xcode.launch.GDBMI_Config;
remoteHostInfo = "";
startActionInfo = "";
};
};
cppStopOnCatchEnabled = 0;
cppStopOnThrowEnabled = 0;
customDataFormattersEnabled = 1;
debuggerPlugin = GDBDebugging;
disassemblyDisplayState = 0;
dylibVariantSuffix = _debug;
enableDebugStr = 0;
environmentEntries = (
{
active = YES;
name = TCL_LIBRARY;
value = "${SRCROOT}/../../tcl/library";
},
{
active = NO;
name = DYLD_PRINT_LIBRARIES;
},
);
isa = PBXExecutable;
launchableReference = F5C37CF303D5BEDF016F146B;
libgmallocEnabled = 0;
name = tcltest;
shlibInfoDictList = (
);
sourceDirectories = (
);
startupPath = "<<ProductDirectory>>";
};
F594E5F1030774B1016F146B = {
activeArgIndex = 2147483647;
activeArgIndices = (
);
argumentStrings = (
);
configStateDict = {
"PBXLSLaunchAction-0" = {
PBXLSLaunchAction = 0;
PBXLSLaunchStartAction = 1;
PBXLSLaunchStdioStyle = 2;
PBXLSLaunchStyle = 0;
class = PBXLSRunLaunchConfig;
displayName = "Executable Runner";
identifier = com.apple.Xcode.launch.runConfig;
remoteHostInfo = "";
startActionInfo = "";
};
"PBXLSLaunchAction-1" = {
PBXLSLaunchAction = 1;
PBXLSLaunchStartAction = 1;
PBXLSLaunchStdioStyle = 2;
PBXLSLaunchStyle = 0;
class = PBXGDB_LaunchConfig;
displayName = GDB;
identifier = com.apple.Xcode.launch.GDBMI_Config;
remoteHostInfo = "";
startActionInfo = "";
};
};
cppStopOnCatchEnabled = 0;
cppStopOnThrowEnabled = 0;
customDataFormattersEnabled = 1;
debuggerPlugin = GDBDebugging;
disassemblyDisplayState = 0;
dylibVariantSuffix = _debug;
enableDebugStr = 0;
environmentEntries = (
{
active = NO;
name = DYLD_PRINT_LIBRARIES;
},
);
isa = PBXExecutable;
launchableReference = F98F02E608E7EF9A00D0320A;
libgmallocEnabled = 0;
name = tclsh;
shlibInfoDictList = (
);
sourceDirectories = (
);
startupPath = "<<ProductDirectory>>";
};
F5C37CF303D5BEDF016F146B = {
isa = PBXFileReference;
lastKnownFileType = "compiled.mach-o.executable";
path = tcltest;
refType = 3;
sourceTree = BUILT_PRODUCTS_DIR;
};
F98F02E608E7EF9A00D0320A = {
isa = PBXFileReference;
lastKnownFileType = "compiled.mach-o.executable";
path = tclsh8.4;
refType = 3;
sourceTree = BUILT_PRODUCTS_DIR;
};
F9D167E30610239A0027C147 = {
fallbackIsa = XCSourceControlManager;
isSCMEnabled = 0;
isa = PBXSourceControlManager;
scmConfiguration = {
};
scmType = scm.cvs;
};
F9D167E40610239A0027C147 = {
indexTemplatePath = "";
isa = PBXCodeSenseManager;
usesDefaults = 1;
wantsCodeCompletion = 1;
wantsCodeCompletionAutoSuggestions = 1;
wantsCodeCompletionCaseSensitivity = 1;
wantsCodeCompletionListAlways = 1;
wantsCodeCompletionOnlyMatchingItems = 1;
wantsCodeCompletionParametersIncluded = 1;
wantsCodeCompletionPlaceholdersInserted = 1;
wantsCodeCompletionTabCompletes = 1;
wantsIndex = 1;
};
}
|
Changes to macosx/Tcl.pbproj/project.pbxproj.
1 2 3 4 5 |
// !$*UTF8*$!
{
archiveVersion = 1;
classes = {
};
| | | < | < < < < < < < < < | < < < < < < < < < < < < < < < < > < < < | < < < | < | | < < < < < < < < < < < < < < < < < | < < < < < | < | < < < < < | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | > > < | < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
// !$*UTF8*$!
{
archiveVersion = 1;
classes = {
};
objectVersion = 39;
objects = {
00E2F845016E82EB0ACA28DC = {
buildSettings = {
};
buildStyles = (
00E2F847016E82EB0ACA28DC,
00E2F848016E82EB0ACA28DC,
);
hasScannedForEncodings = 1;
isa = PBXProject;
mainGroup = 00E2F846016E82EB0ACA28DC;
productRefGroup = 00E2F84A016E8A830ACA28DC;
projectDirPath = "";
targets = (
00E2F84C016E8B780ACA28DC,
);
};
00E2F846016E82EB0ACA28DC = {
children = (
F5306CA003CAC9AE016F146B,
F5306C9F03CAC979016F146B,
F5C88655017D604601DC9062,
F5F24FEE016ED0DF01DC9062,
00E2F855016E922C0ACA28DC,
00E2F857016E92B00ACA28DC,
00E2F85A016E92B00ACA28DC,
00E2F84A016E8A830ACA28DC,
);
isa = PBXGroup;
refType = 4;
sourceTree = "<group>";
};
00E2F847016E82EB0ACA28DC = {
buildSettings = {
MAKE_TARGET = develop;
};
isa = PBXBuildStyle;
name = Development;
};
00E2F848016E82EB0ACA28DC = {
buildSettings = {
MAKE_TARGET = deploy;
};
isa = PBXBuildStyle;
name = Deployment;
};
00E2F84A016E8A830ACA28DC = {
children = (
F53ACC73031DA405016F146B,
F53ACC5C031D9D11016F146B,
F9A61C9D04C2B4E3006F5A0B,
);
isa = PBXGroup;
name = Products;
refType = 4;
sourceTree = "<group>";
};
00E2F84C016E8B780ACA28DC = {
buildArgumentsString = "-c \"cd \\\"${TCL_SRCROOT}/macosx\\\" && ACTION=${ACTION} && gnumake \\${ACTION:+\\${ACTION/clean/distclean}-}${MAKE_TARGET} INSTALL_ROOT=\\\"${DSTROOT}\\\" INSTALL_PATH=\\\"${INSTALL_PATH}\\\" PREFIX=\\\"${PREFIX}\\\" BINDIR=\\\"${BINDIR}\\\" MANDIR=\\\"${MANDIR}\\\" \\${EXTRA_MAKE_FLAGS} ${ALL_SETTINGS}\"";
buildPhases = (
);
buildSettings = {
BINDIR = "${PREFIX}/bin";
INSTALL_PATH = /Library/Frameworks;
MANDIR = "${PREFIX}/man";
PREFIX = /usr/local;
PRODUCT_NAME = Tcl;
TCL_SRCROOT = "${SRCROOT}/../../tcl";
TEMP_DIR = "${PROJECT_TEMP_DIR}";
};
buildToolPath = /bin/bash;
buildWorkingDirectory = "${SRCROOT}";
dependencies = (
);
isa = PBXLegacyTarget;
name = Tcl;
passBuildSettingsInEnvironment = 0;
productName = Tcl;
};
00E2F854016E922C0ACA28DC = {
children = (
F5F24F87016ECAFC01DC9062,
F5F24F88016ECAFC01DC9062,
F5F24F89016ECAFC01DC9062,
F5F24F8A016ECAFC01DC9062,
|
| ︙ | ︙ | |||
298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
F5F24FCF016ECAFC01DC9062,
F5F24FD0016ECAFC01DC9062,
);
isa = PBXGroup;
name = Sources;
path = "";
refType = 4;
};
00E2F855016E922C0ACA28DC = {
children = (
00E2F856016E92B00ACA28DC,
00E2F854016E922C0ACA28DC,
);
isa = PBXGroup;
name = generic;
refType = 4;
};
00E2F856016E92B00ACA28DC = {
children = (
F5F24F6B016ECAA401DC9062,
F5F24F6C016ECAA401DC9062,
F5F24F6D016ECAA401DC9062,
F5F24F6E016ECAA401DC9062,
| > > | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
F5F24FCF016ECAFC01DC9062,
F5F24FD0016ECAFC01DC9062,
);
isa = PBXGroup;
name = Sources;
path = "";
refType = 4;
sourceTree = "<group>";
};
00E2F855016E922C0ACA28DC = {
children = (
00E2F856016E92B00ACA28DC,
00E2F854016E922C0ACA28DC,
);
isa = PBXGroup;
name = generic;
refType = 4;
sourceTree = "<group>";
};
00E2F856016E92B00ACA28DC = {
children = (
F5F24F6B016ECAA401DC9062,
F5F24F6C016ECAA401DC9062,
F5F24F6D016ECAA401DC9062,
F5F24F6E016ECAA401DC9062,
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 |
F5F24F78016ECAA401DC9062,
F5F24FD1016ECB1E01DC9062,
F5F24FD2016ECB1E01DC9062,
);
isa = PBXGroup;
name = Headers;
refType = 4;
};
00E2F857016E92B00ACA28DC = {
children = (
00E2F858016E92B00ACA28DC,
00E2F859016E92B00ACA28DC,
);
isa = PBXGroup;
name = macosx;
refType = 4;
};
00E2F858016E92B00ACA28DC = {
children = (
);
isa = PBXGroup;
name = Headers;
refType = 4;
};
00E2F859016E92B00ACA28DC = {
children = (
F5A1836F018242A501DC9062,
);
isa = PBXGroup;
name = Sources;
refType = 4;
};
00E2F85A016E92B00ACA28DC = {
children = (
00E2F85B016E92B00ACA28DC,
00E2F85C016E92B00ACA28DC,
);
isa = PBXGroup;
name = unix;
refType = 4;
};
00E2F85B016E92B00ACA28DC = {
children = (
F5F24FD6016ECC0F01DC9062,
F5F24FD7016ECC0F01DC9062,
);
isa = PBXGroup;
name = Headers;
refType = 4;
};
00E2F85C016E92B00ACA28DC = {
children = (
F5F24FD8016ECC0F01DC9062,
F5F24FD9016ECC0F01DC9062,
F5F24FDB016ECC0F01DC9062,
F5F24FDC016ECC0F01DC9062,
| > > > > > > | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 |
F5F24F78016ECAA401DC9062,
F5F24FD1016ECB1E01DC9062,
F5F24FD2016ECB1E01DC9062,
);
isa = PBXGroup;
name = Headers;
refType = 4;
sourceTree = "<group>";
};
00E2F857016E92B00ACA28DC = {
children = (
00E2F858016E92B00ACA28DC,
00E2F859016E92B00ACA28DC,
);
isa = PBXGroup;
name = macosx;
refType = 4;
sourceTree = "<group>";
};
00E2F858016E92B00ACA28DC = {
children = (
);
isa = PBXGroup;
name = Headers;
refType = 4;
sourceTree = "<group>";
};
00E2F859016E92B00ACA28DC = {
children = (
F5A1836F018242A501DC9062,
);
isa = PBXGroup;
name = Sources;
refType = 4;
sourceTree = "<group>";
};
00E2F85A016E92B00ACA28DC = {
children = (
00E2F85B016E92B00ACA28DC,
00E2F85C016E92B00ACA28DC,
);
isa = PBXGroup;
name = unix;
refType = 4;
sourceTree = "<group>";
};
00E2F85B016E92B00ACA28DC = {
children = (
F5F24FD6016ECC0F01DC9062,
F5F24FD7016ECC0F01DC9062,
);
isa = PBXGroup;
name = Headers;
refType = 4;
sourceTree = "<group>";
};
00E2F85C016E92B00ACA28DC = {
children = (
F5F24FD8016ECC0F01DC9062,
F5F24FD9016ECC0F01DC9062,
F5F24FDB016ECC0F01DC9062,
F5F24FDC016ECC0F01DC9062,
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 | F5F24FE5016ECC0F01DC9062, F5F24FE6016ECC0F01DC9062, F5F24FE7016ECC0F01DC9062, ); isa = PBXGroup; name = Sources; refType = 4; }; //000 //001 //002 //003 //004 //F50 //F51 //F52 //F53 //F54 | > < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > | > | < | > | > | < | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > < < < | < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
F5F24FE5016ECC0F01DC9062,
F5F24FE6016ECC0F01DC9062,
F5F24FE7016ECC0F01DC9062,
);
isa = PBXGroup;
name = Sources;
refType = 4;
sourceTree = "<group>";
};
//000
//001
//002
//003
//004
//F50
//F51
//F52
//F53
//F54
F5306C9F03CAC979016F146B = {
children = (
F5306CA303CAC9DE016F146B,
F5306CA103CAC9DE016F146B,
F5306CA203CAC9DE016F146B,
);
isa = PBXGroup;
name = "Build System";
refType = 4;
sourceTree = "<group>";
};
F5306CA003CAC9AE016F146B = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = text;
name = ChangeLog;
path = ../ChangeLog;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5306CA103CAC9DE016F146B = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = text.script.sh;
name = configure.in;
path = ../unix/configure.in;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5306CA203CAC9DE016F146B = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = text;
name = Makefile.in;
path = ../unix/Makefile.in;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5306CA303CAC9DE016F146B = {
isa = PBXFileReference;
lastKnownFileType = text;
name = tcl.m4;
path = ../unix/tcl.m4;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F53ACC5C031D9D11016F146B = {
isa = PBXFileReference;
lastKnownFileType = "compiled.mach-o.executable";
path = tclsh8.4;
refType = 3;
sourceTree = BUILT_PRODUCTS_DIR;
};
F53ACC73031DA405016F146B = {
isa = PBXFileReference;
lastKnownFileType = "compiled.mach-o.executable";
path = tcltest;
refType = 3;
sourceTree = BUILT_PRODUCTS_DIR;
};
F5A1836F018242A501DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
path = tclMacOSXBundle.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5C88655017D604601DC9062 = {
children = (
F5C88656017D604601DC9062,
F5C88657017D60C901DC9062,
F5C88658017D60C901DC9062,
);
isa = PBXGroup;
name = "Header Tools";
refType = 4;
sourceTree = "<group>";
};
F5C88656017D604601DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = genStubs.tcl;
path = ../tools/genStubs.tcl;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5C88657017D60C901DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = tcl.decls;
path = ../generic/tcl.decls;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5C88658017D60C901DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = tclInt.decls;
path = ../generic/tclInt.decls;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F6B016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = regcustom.h;
path = ../generic/regcustom.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F6C016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = regerrs.h;
path = ../generic/regerrs.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F6D016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = regguts.h;
path = ../generic/regguts.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F6E016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tcl.h;
path = ../generic/tcl.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F6F016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclCompile.h;
path = ../generic/tclCompile.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F70016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclDecls.h;
path = ../generic/tclDecls.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F71016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclInitScript.h;
path = ../generic/tclInitScript.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F72016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclInt.h;
path = ../generic/tclInt.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F73016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclIntDecls.h;
path = ../generic/tclIntDecls.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F74016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclIntPlatDecls.h;
path = ../generic/tclIntPlatDecls.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F75016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclIO.h;
path = ../generic/tclIO.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F76016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclMath.h;
path = ../generic/tclMath.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F77016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclPlatDecls.h;
path = ../generic/tclPlatDecls.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F78016ECAA401DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclRegexp.h;
path = ../generic/tclRegexp.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F87016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regc_color.c;
path = ../generic/regc_color.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F88016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regc_cvec.c;
path = ../generic/regc_cvec.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F89016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regc_lex.c;
path = ../generic/regc_lex.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F8A016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regc_locale.c;
path = ../generic/regc_locale.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F8B016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regc_nfa.c;
path = ../generic/regc_nfa.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F8C016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regcomp.c;
path = ../generic/regcomp.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F8D016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = rege_dfa.c;
path = ../generic/rege_dfa.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F8E016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regerror.c;
path = ../generic/regerror.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F8F016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regexec.c;
path = ../generic/regexec.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F90016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regfree.c;
path = ../generic/regfree.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F91016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = regfronts.c;
path = ../generic/regfronts.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F92016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclAlloc.c;
path = ../generic/tclAlloc.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F93016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclAsync.c;
path = ../generic/tclAsync.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F94016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclBasic.c;
path = ../generic/tclBasic.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F95016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclBinary.c;
path = ../generic/tclBinary.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F96016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclCkalloc.c;
path = ../generic/tclCkalloc.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F97016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclClock.c;
path = ../generic/tclClock.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F98016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclCmdAH.c;
path = ../generic/tclCmdAH.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F99016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclCmdIL.c;
path = ../generic/tclCmdIL.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F9A016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclCmdMZ.c;
path = ../generic/tclCmdMZ.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F9B016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclCompCmds.c;
path = ../generic/tclCompCmds.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F9C016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclCompExpr.c;
path = ../generic/tclCompExpr.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F9D016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclCompile.c;
path = ../generic/tclCompile.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F9E016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclDate.c;
path = ../generic/tclDate.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24F9F016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclEncoding.c;
path = ../generic/tclEncoding.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA0016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclEnv.c;
path = ../generic/tclEnv.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA1016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclEvent.c;
path = ../generic/tclEvent.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA2016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclExecute.c;
path = ../generic/tclExecute.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA3016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclFCmd.c;
path = ../generic/tclFCmd.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA4016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclFileName.c;
path = ../generic/tclFileName.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA5016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclGet.c;
path = ../generic/tclGet.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA6016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclHash.c;
path = ../generic/tclHash.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA7016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclHistory.c;
path = ../generic/tclHistory.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA8016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclIndexObj.c;
path = ../generic/tclIndexObj.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FA9016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclInterp.c;
path = ../generic/tclInterp.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FAA016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclIO.c;
path = ../generic/tclIO.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FAB016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclIOCmd.c;
path = ../generic/tclIOCmd.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FAC016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclIOGT.c;
path = ../generic/tclIOGT.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FAD016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclIOSock.c;
path = ../generic/tclIOSock.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FAE016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclIOUtil.c;
path = ../generic/tclIOUtil.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FAF016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclLink.c;
path = ../generic/tclLink.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB0016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclListObj.c;
path = ../generic/tclListObj.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB1016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclLiteral.c;
path = ../generic/tclLiteral.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB2016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclLoad.c;
path = ../generic/tclLoad.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB3016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclLoadNone.c;
path = ../generic/tclLoadNone.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB4016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclMain.c;
path = ../generic/tclMain.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB5016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclNamesp.c;
path = ../generic/tclNamesp.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB6016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclNotify.c;
path = ../generic/tclNotify.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB7016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclObj.c;
path = ../generic/tclObj.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB8016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclPanic.c;
path = ../generic/tclPanic.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FB9016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclParse.c;
path = ../generic/tclParse.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FBA016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclParseExpr.c;
path = ../generic/tclParseExpr.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FBB016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclPipe.c;
path = ../generic/tclPipe.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FBC016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclPosixStr.c;
path = ../generic/tclPosixStr.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FBD016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclPreserve.c;
path = ../generic/tclPreserve.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FBE016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclProc.c;
path = ../generic/tclProc.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FBF016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclRegexp.c;
path = ../generic/tclRegexp.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC0016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclResolve.c;
path = ../generic/tclResolve.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC1016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclResult.c;
path = ../generic/tclResult.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC2016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclScan.c;
path = ../generic/tclScan.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC3016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclStringObj.c;
path = ../generic/tclStringObj.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC4016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclStubInit.c;
path = ../generic/tclStubInit.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC5016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclStubLib.c;
path = ../generic/tclStubLib.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC6016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclTest.c;
path = ../generic/tclTest.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC7016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclTestObj.c;
path = ../generic/tclTestObj.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC8016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclTestProcBodyObj.c;
path = ../generic/tclTestProcBodyObj.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FC9016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclThread.c;
path = ../generic/tclThread.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FCA016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclThreadJoin.c;
path = ../generic/tclThreadJoin.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FCB016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclThreadTest.c;
path = ../generic/tclThreadTest.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FCC016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclTimer.c;
path = ../generic/tclTimer.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FCD016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUniData.c;
path = ../generic/tclUniData.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FCE016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUtf.c;
path = ../generic/tclUtf.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FCF016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUtil.c;
path = ../generic/tclUtil.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FD0016ECAFC01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclVar.c;
path = ../generic/tclVar.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FD1016ECB1E01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = regex.h;
path = ../generic/regex.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FD2016ECB1E01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclPort.h;
path = ../generic/tclPort.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FD3016ECB4901DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclPkg.c;
path = ../generic/tclPkg.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FD6016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclUnixPort.h;
path = ../unix/tclUnixPort.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FD7016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.h;
name = tclUnixThrd.h;
path = ../unix/tclUnixThrd.h;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FD8016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclAppInit.c;
path = ../unix/tclAppInit.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FD9016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclLoadDyld.c;
path = ../unix/tclLoadDyld.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FDB016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixChan.c;
path = ../unix/tclUnixChan.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FDC016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixEvent.c;
path = ../unix/tclUnixEvent.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FDD016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixFCmd.c;
path = ../unix/tclUnixFCmd.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FDE016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixFile.c;
path = ../unix/tclUnixFile.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FDF016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixInit.c;
path = ../unix/tclUnixInit.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FE0016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixNotfy.c;
path = ../unix/tclUnixNotfy.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FE1016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixPipe.c;
path = ../unix/tclUnixPipe.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FE2016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixSock.c;
path = ../unix/tclUnixSock.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FE3016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixTest.c;
path = ../unix/tclUnixTest.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FE4016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixThrd.c;
path = ../unix/tclUnixThrd.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FE5016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclUnixTime.c;
path = ../unix/tclUnixTime.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FE6016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclXtNotify.c;
path = ../unix/tclXtNotify.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FE7016ECC0F01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = sourcecode.c.c;
name = tclXtTest.c;
path = ../unix/tclXtTest.c;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FEE016ED0DF01DC9062 = {
children = (
F5F24FEF016ED0DF01DC9062,
F5F24FF0016ED0DF01DC9062,
F5F24FF3016ED0DF01DC9062,
F5F24FF4016ED0DF01DC9062,
|
| ︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 |
F5F25007016ED0DF01DC9062,
F5F25008016ED0DF01DC9062,
F5F2500A016ED0DF01DC9062,
);
isa = PBXGroup;
name = Scripts;
refType = 4;
};
F5F24FEF016ED0DF01DC9062 = {
isa = PBXFileReference;
name = auto.tcl;
path = ../library/auto.tcl;
refType = 2;
};
F5F24FF0016ED0DF01DC9062 = {
includeInIndex = 0;
| > > > | > > | > > > > | > > | > > > > > > | > > | > > > > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > | 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 |
F5F25007016ED0DF01DC9062,
F5F25008016ED0DF01DC9062,
F5F2500A016ED0DF01DC9062,
);
isa = PBXGroup;
name = Scripts;
refType = 4;
sourceTree = "<group>";
};
F5F24FEF016ED0DF01DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = auto.tcl;
path = ../library/auto.tcl;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FF0016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFileReference;
lastKnownFileType = folder;
name = dde;
path = ../library/dde;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FF3016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFileReference;
lastKnownFileType = folder;
name = encoding;
path = ../library/encoding;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FF4016ED0DF01DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = history.tcl;
path = ../library/history.tcl;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FF5016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFileReference;
lastKnownFileType = folder;
name = http;
path = ../library/http;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FF6016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFileReference;
lastKnownFileType = folder;
name = http1.0;
path = ../library/http1.0;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FFA016ED0DF01DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = init.tcl;
path = ../library/init.tcl;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FFB016ED0DF01DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = ldAout.tcl;
path = ../library/ldAout.tcl;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FFC016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFileReference;
lastKnownFileType = folder;
name = msgcat;
path = ../library/msgcat;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F24FFE016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFileReference;
lastKnownFileType = folder;
name = opt;
path = ../library/opt;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F25001016ED0DF01DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = package.tcl;
path = ../library/package.tcl;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F25002016ED0DF01DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = parray.tcl;
path = ../library/parray.tcl;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F25003016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFileReference;
lastKnownFileType = folder;
name = reg;
path = ../library/reg;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F25005016ED0DF01DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = safe.tcl;
path = ../library/safe.tcl;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F25007016ED0DF01DC9062 = {
fileEncoding = 5;
isa = PBXFileReference;
lastKnownFileType = text;
name = tclIndex;
path = ../library/tclIndex;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F25008016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFileReference;
lastKnownFileType = folder;
name = tcltest;
path = ../library/tcltest;
refType = 2;
sourceTree = SOURCE_ROOT;
};
F5F2500A016ED0DF01DC9062 = {
isa = PBXFileReference;
lastKnownFileType = text;
name = word.tcl;
path = ../library/word.tcl;
refType = 2;
sourceTree = SOURCE_ROOT;
};
//F50
//F51
//F52
//F53
//F54
//F90
//F91
//F92
//F93
//F94
F9A61C9D04C2B4E3006F5A0B = {
explicitFileType = wrapper.framework;
isa = PBXFileReference;
path = Tcl.framework;
refType = 3;
sourceTree = BUILT_PRODUCTS_DIR;
};
};
rootObject = 00E2F845016E82EB0ACA28DC;
}
|
Added macosx/Tclsh-Info.plist.in.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | <?xml version="1.0" encoding="UTF-8"?> <!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd"> <!-- Copyright (c) 2005-2007 Daniel A. Steffen <das@users.sourceforge.net> See the file "license.terms" for information on usage and redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. RCS: @(#) $Id: Tclsh-Info.plist.in,v 1.1.2.2 2007/06/06 09:54:33 das Exp $ --> <plist version="1.0"> <dict> <key>CFBundleDevelopmentRegion</key> <string>English</string> <key>CFBundleExecutable</key> <string>tclsh@TCL_VERSION@</string> <key>CFBundleGetInfoString</key> <string>Tcl Shell @TCL_VERSION@@TCL_PATCH_LEVEL@, Copyright © @TCL_YEAR@ Tcl Core Team, Copyright © 2001-@TCL_YEAR@ Daniel A. Steffen, Initial MacOS X Port by Jim Ingham & Ian Reid, Copyright © 2001-2002, Apple Computer, Inc.</string> <key>CFBundleIdentifier</key> <string>com.tcltk.tclsh</string> <key>CFBundleInfoDictionaryVersion</key> <string>6.0</string> <key>CFBundleName</key> <string>tclsh</string> <key>CFBundlePackageType</key> <string>APPL</string> <key>CFBundleShortVersionString</key> <string>@TCL_VERSION@@TCL_PATCH_LEVEL@</string> <key>CFBundleSignature</key> <string>TclS</string> <key>CFBundleVersion</key> <string>@TCL_VERSION@@TCL_PATCH_LEVEL@</string> </dict> </plist> |
Changes to macosx/tclMacOSXBundle.c.
1 2 3 | /* * tclMacOSXBundle.c -- * | | | | > > > > | | | < | | | < | | | | | | < | | | | | < | | | | | | | | | | < | | | | | | | < > > > > > | > | < | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > | < > | > > > | > | > > > | | > | > | > > > | > > > > | > > > > > > > > > | > > < > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | > | > > | | | < | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
/*
* tclMacOSXBundle.c --
*
* This file implements functions that inspect CFBundle structures on
* MacOS X.
*
* Copyright 2001, Apple Computer, Inc.
* Copyright (c) 2003-2007 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* The following terms apply to all files originating from Apple
* Computer, Inc. ("Apple") and associated with the software unless
* explicitly disclaimed in individual files.
*
* Apple hereby grants permission to use, copy, modify, distribute, and
* license this software and its documentation for any purpose, provided
* that existing copyright notices are retained in all copies and that
* this notice is included verbatim in any distributions. No written
* agreement, license, or royalty fee is required for any of the
* authorized uses. Modifications to this software may be copyrighted by
* their authors and need not follow the licensing terms described here,
* provided that the new terms are clearly indicated on the first page of
* each file where they apply.
*
* IN NO EVENT SHALL APPLE, THE AUTHORS OR DISTRIBUTORS OF THE SOFTWARE
* BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR
* CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS
* DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF APPLE OR THE
* AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. APPLE,
* THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND
* NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND
* APPLE,THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE
* MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
*
* GOVERNMENT USE: If you are acquiring this software on behalf of the
* U.S. government, the Government shall have only "Restricted Rights" in
* the software and related documentation as defined in the Federal
* Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you are
* acquiring the software on behalf of the Department of Defense, the
* software shall be classified as "Commercial Computer Software" and the
* Government shall have only "Restricted Rights" as defined in Clause
* 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, the
* authors grant the U.S. Government and others acting in its behalf
* permission to use and distribute the software in accordance with the
* terms specified in this license.
*
* RCS: @(#) $Id: tclMacOSXBundle.c,v 1.3.2.6 2007/04/29 02:21:33 das Exp $
*/
#include "tclPort.h"
#ifdef HAVE_COREFOUNDATION
#include <CoreFoundation/CoreFoundation.h>
#include <mach-o/dyld.h>
#endif /* HAVE_COREFOUNDATION */
/*
*----------------------------------------------------------------------
*
* Tcl_MacOSXOpenBundleResources --
*
* Given the bundle name for a shared library, this routine sets
* libraryPath to the Resources/Scripts directory in the framework
* package. If hasResourceFile is true, it will also open the main
* resource file for the bundle.
*
* Results:
* TCL_OK if the bundle could be opened, and the Scripts folder found.
* TCL_ERROR otherwise.
*
* Side effects:
* libraryVariableName may be set, and the resource file opened.
*
*----------------------------------------------------------------------
*/
int
Tcl_MacOSXOpenBundleResources(
Tcl_Interp *interp,
CONST char *bundleName,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
{
return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName,
NULL, hasResourceFile, maxPathLen, libraryPath);
}
/*
*----------------------------------------------------------------------
*
* Tcl_MacOSXOpenVersionedBundleResources --
*
* Given the bundle and version name for a shared library (version name
* can be NULL to indicate latest version), this routine sets libraryPath
* to the Resources/Scripts directory in the framework package. If
* hasResourceFile is true, it will also open the main resource file for
* the bundle.
*
* Results:
* TCL_OK if the bundle could be opened, and the Scripts folder found.
* TCL_ERROR otherwise.
*
* Side effects:
* libraryVariableName may be set, and the resource file opened.
*
*----------------------------------------------------------------------
*/
int
Tcl_MacOSXOpenVersionedBundleResources(
Tcl_Interp *interp,
CONST char *bundleName,
CONST char *bundleVersion,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
{
#ifdef HAVE_COREFOUNDATION
CFBundleRef bundleRef;
CFStringRef bundleNameRef;
CFURLRef libURL;
libraryPath[0] = '\0';
bundleNameRef = CFStringCreateWithCString(NULL, bundleName,
kCFStringEncodingUTF8);
bundleRef = CFBundleGetBundleWithIdentifier(bundleNameRef);
CFRelease(bundleNameRef);
if (bundleVersion && bundleRef) {
/*
* Create bundle from bundleVersion subdirectory of 'Versions'.
*/
CFBundleRef versionedBundleRef = NULL;
CFURLRef versionedBundleURL = NULL;
CFStringRef bundleVersionRef = CFStringCreateWithCString(NULL,
bundleVersion, kCFStringEncodingUTF8);
CFURLRef bundleURL = CFBundleCopyBundleURL(bundleRef);
if (bundleURL) {
CFStringRef bundleTailRef = CFURLCopyLastPathComponent(bundleURL);
if (bundleTailRef) {
if (CFStringCompare(bundleTailRef, bundleVersionRef, 0) ==
kCFCompareEqualTo) {
versionedBundleRef = bundleRef;
}
CFRelease(bundleTailRef);
}
}
if (bundleURL && !versionedBundleRef) {
CFURLRef versURL = CFURLCreateCopyAppendingPathComponent(NULL,
bundleURL, CFSTR("Versions"), TRUE);
if (versURL) {
versionedBundleURL = CFURLCreateCopyAppendingPathComponent(
NULL, versURL, bundleVersionRef, TRUE);
CFRelease(versURL);
}
CFRelease(bundleURL);
}
CFRelease(bundleVersionRef);
if (versionedBundleURL) {
versionedBundleRef = CFBundleCreate(NULL, versionedBundleURL);
CFRelease(versionedBundleURL);
}
bundleRef = versionedBundleRef;
}
if (bundleRef) {
if (hasResourceFile) {
/*
* Dynamically acquire address for CFBundleOpenBundleResourceMap
* symbol, since it is only present in full CoreFoundation on Mac
* OS X and not in CFLite on pure Darwin.
*/
static int initialized = FALSE;
static short (*openresourcemap)(CFBundleRef) = NULL;
if (!initialized) {
NSSymbol nsSymbol = NULL;
if (NSIsSymbolNameDefinedWithHint(
"_CFBundleOpenBundleResourceMap", "CoreFoundation")) {
nsSymbol = NSLookupAndBindSymbolWithHint(
"_CFBundleOpenBundleResourceMap","CoreFoundation");
if (nsSymbol) {
openresourcemap = NSAddressOfSymbol(nsSymbol);
}
}
initialized = TRUE;
}
if (openresourcemap) {
short refNum;
refNum = openresourcemap(bundleRef);
}
}
libURL = CFBundleCopyResourceURL(bundleRef, CFSTR("Scripts"),
NULL, NULL);
if (libURL) {
/*
* FIXME: This is a quick fix, it is probably not right for
* internationalization.
*/
CFURLGetFileSystemRepresentation(libURL, TRUE,
(unsigned char*) libraryPath, maxPathLen);
CFRelease(libURL);
}
}
if (libraryPath[0]) {
return TCL_OK;
} else {
return TCL_ERROR;
}
#else /* HAVE_COREFOUNDATION */
return TCL_ERROR;
#endif /* HAVE_COREFOUNDATION */
}
|
Added macosx/tclMacOSXNotify.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 |
/*
* tclMacOSXNotify.c --
*
* This file contains the implementation of a merged CFRunLoop/select()
* based notifier, which is the lowest-level part of the Tcl event loop.
* This file works together with generic/tclNotify.c.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright 2001, Apple Computer, Inc.
* Copyright (c) 2005-2007 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclMacOSXNotify.c,v 1.1.2.12 2007/04/29 02:21:33 das Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#ifdef HAVE_COREFOUNDATION /* Traditional unix select-based notifier is
* in tclUnixNotfy.c */
#include <CoreFoundation/CoreFoundation.h>
#include <pthread.h>
extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;
/*
* This structure is used to keep track of the notifier info for a registered
* file.
*/
typedef struct FileHandler {
int fd;
int mask; /* Mask of desired events: TCL_READABLE,
* etc. */
int readyMask; /* Mask of events that have been seen since
* the last time file handlers were invoked
* for this file. */
Tcl_FileProc *proc; /* Function to call, in the style of
* Tcl_CreateFileHandler. */
ClientData clientData; /* Argument to pass to proc. */
struct FileHandler *nextPtr;/* Next in list of all files we care about. */
} FileHandler;
/*
* The following structure is what is added to the Tcl event queue when file
* handlers are ready to fire.
*/
typedef struct FileHandlerEvent {
Tcl_Event header; /* Information that is standard for all
* events. */
int fd; /* File descriptor that is ready. Used to find
* the FileHandler structure for the file
* (can't point directly to the FileHandler
* structure because it could go away while
* the event is queued). */
} FileHandlerEvent;
/*
* The following structure contains a set of select() masks to track readable,
* writable, and exceptional conditions.
*/
typedef struct SelectMasks {
fd_set readable;
fd_set writable;
fd_set exceptional;
} SelectMasks;
/*
* The following static structure contains the state information for the
* select based implementation of the Tcl notifier. One of these structures is
* created for each thread that is using the notifier.
*/
typedef struct ThreadSpecificData {
FileHandler *firstFileHandlerPtr;
/* Pointer to head of file handler list. */
SelectMasks checkMasks; /* This structure is used to build up the
* masks to be used in the next call to
* select. Bits are set in response to calls
* to Tcl_CreateFileHandler. */
SelectMasks readyMasks; /* This array reflects the readable/writable
* conditions that were found to exist by the
* last call to select. */
int numFdBits; /* Number of valid bits in checkMasks (one
* more than highest fd for which
* Tcl_WatchFile has been called). */
int onList; /* True if it is in this list */
unsigned int pollState; /* pollState is used to implement a polling
* handshake between each thread and the
* notifier thread. Bits defined below. */
struct ThreadSpecificData *nextPtr, *prevPtr;
/* All threads that are currently waiting on
* an event have their ThreadSpecificData
* structure on a doubly-linked listed formed
* from these pointers. You must hold the
* notifierLock before accessing these
* fields. */
CFRunLoopSourceRef runLoopSource;
/* Any other thread alerts a notifier that an
* event is ready to be processed by signaling
* this CFRunLoopSource. */
CFRunLoopRef runLoop; /* This thread's CFRunLoop, needs to be woken
* up whenever the runLoopSource is
* signaled. */
int eventReady; /* True if an event is ready to be
* processed. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* The following static indicates the number of threads that have initialized
* notifiers.
*
* You must hold the notifierInitLock before accessing this variable.
*/
static int notifierCount = 0;
/*
* The following variable points to the head of a doubly-linked list of
* ThreadSpecificData structures for all threads that are currently waiting on
* an event.
*
* You must hold the notifierLock before accessing this list.
*/
static ThreadSpecificData *waitingListPtr = NULL;
/*
* The notifier thread spends all its time in select() waiting for a file
* descriptor associated with one of the threads on the waitingListPtr list to
* do something interesting. But if the contents of the waitingListPtr list
* ever changes, we need to wake up and restart the select() system call. You
* can wake up the notifier thread by writing a single byte to the file
* descriptor defined below. This file descriptor is the input-end of a pipe
* and the notifier thread is listening for data on the output-end of the same
* pipe. Hence writing to this file descriptor will cause the select() system
* call to return and wake up the notifier thread.
*
* You must hold the notifierLock lock before writing to the pipe.
*/
static int triggerPipe = -1;
static int receivePipe = -1; /* Output end of triggerPipe */
/*
* We use the Darwin-native spinlock API rather than pthread mutexes for
* notifier locking: this radically simplifies the implementation and lowers
* overhead. Note that these are not pure spinlocks, they employ various
* strategies to back off and relinquish the processor, making them immune to
* most priority-inversion livelocks (c.f. 'man 3 OSSpinLockLock' and Darwin
* sources: xnu/osfmk/{ppc,i386}/commpage/spinlocks.s).
*/
#if defined(HAVE_LIBKERN_OSATOMIC_H) && defined(HAVE_OSSPINLOCKLOCK)
/*
* Use OSSpinLock API where available (Tiger or later).
*/
#include <libkern/OSAtomic.h>
#if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040
/*
* Support for weakly importing spinlock API.
*/
#define WEAK_IMPORT_SPINLOCKLOCK
#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1050
#define VOLATILE volatile
#else
#define VOLATILE
#endif
#ifndef bool
#define bool int
#endif
extern void OSSpinLockLock(VOLATILE OSSpinLock *lock) WEAK_IMPORT_ATTRIBUTE;
extern void OSSpinLockUnlock(VOLATILE OSSpinLock *lock) WEAK_IMPORT_ATTRIBUTE;
extern bool OSSpinLockTry(VOLATILE OSSpinLock *lock) WEAK_IMPORT_ATTRIBUTE;
extern void _spin_lock(VOLATILE OSSpinLock *lock) WEAK_IMPORT_ATTRIBUTE;
extern void _spin_unlock(VOLATILE OSSpinLock *lock) WEAK_IMPORT_ATTRIBUTE;
extern bool _spin_lock_try(VOLATILE OSSpinLock *lock) WEAK_IMPORT_ATTRIBUTE;
static void (* lockLock)(VOLATILE OSSpinLock *lock) = NULL;
static void (* lockUnlock)(VOLATILE OSSpinLock *lock) = NULL;
static bool (* lockTry)(VOLATILE OSSpinLock *lock) = NULL;
#undef VOLATILE
static pthread_once_t spinLockLockInitControl = PTHREAD_ONCE_INIT;
static void SpinLockLockInit(void) {
lockLock = OSSpinLockLock != NULL ? OSSpinLockLock : _spin_lock;
lockUnlock = OSSpinLockUnlock != NULL ? OSSpinLockUnlock : _spin_unlock;
lockTry = OSSpinLockTry != NULL ? OSSpinLockTry : _spin_lock_try;
if (lockLock == NULL || lockUnlock == NULL) {
Tcl_Panic("SpinLockLockInit: no spinlock API available");
}
}
#define SpinLockLock(p) lockLock(p)
#define SpinLockUnlock(p) lockUnlock(p)
#define SpinLockTry(p) lockTry(p)
#else
#define SpinLockLock(p) OSSpinLockLock(p)
#define SpinLockUnlock(p) OSSpinLockUnlock(p)
#define SpinLockTry(p) OSSpinLockTry(p)
#endif /* HAVE_WEAK_IMPORT */
#define SPINLOCK_INIT OS_SPINLOCK_INIT
#else
/*
* Otherwise, use commpage spinlock SPI directly.
*/
typedef uint32_t OSSpinLock;
extern void _spin_lock(OSSpinLock *lock);
extern void _spin_unlock(OSSpinLock *lock);
extern int _spin_lock_try(OSSpinLock *lock);
#define SpinLockLock(p) _spin_lock(p)
#define SpinLockUnlock(p) _spin_unlock(p)
#define SpinLockTry(p) _spin_lock_try(p)
#define SPINLOCK_INIT 0
#endif /* HAVE_LIBKERN_OSATOMIC_H && HAVE_OSSPINLOCKLOCK */
/*
* These spinlocks lock access to the global notifier state.
*/
static OSSpinLock notifierInitLock = SPINLOCK_INIT;
static OSSpinLock notifierLock = SPINLOCK_INIT;
/*
* Macros abstracting notifier locking/unlocking
*/
#define LOCK_NOTIFIER_INIT SpinLockLock(¬ifierInitLock)
#define UNLOCK_NOTIFIER_INIT SpinLockUnlock(¬ifierInitLock)
#define LOCK_NOTIFIER SpinLockLock(¬ifierLock)
#define UNLOCK_NOTIFIER SpinLockUnlock(¬ifierLock)
/*
* The pollState bits
* POLL_WANT is set by each thread before it waits on its condition
* variable. It is checked by the notifier before it does select.
* POLL_DONE is set by the notifier if it goes into select after seeing
* POLL_WANT. The idea is to ensure it tries a select with the
* same bits the initial thread had set.
*/
#define POLL_WANT 0x1
#define POLL_DONE 0x2
/*
* This is the thread ID of the notifier thread that does select.
*/
static pthread_t notifierThread;
/*
* Custom run loop mode containing only the run loop source for the
* notifier thread.
*/
#ifndef TCL_EVENTS_ONLY_RUN_LOOP_MODE
#define TCL_EVENTS_ONLY_RUN_LOOP_MODE "com.tcltk.tclEventsOnlyRunLoopMode"
#endif
#ifdef __CONSTANT_CFSTRINGS__
#define tclEventsOnlyRunLoopMode CFSTR(TCL_EVENTS_ONLY_RUN_LOOP_MODE)
#else
static CFStringRef tclEventsOnlyRunLoopMode = NULL;
#endif
/*
* Static routines defined in this file.
*/
static void NotifierThreadProc(ClientData clientData)
__attribute__ ((__noreturn__));
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
#ifdef HAVE_PTHREAD_ATFORK
static int atForkInit = 0;
static void AtForkPrepare(void);
static void AtForkParent(void);
static void AtForkChild(void);
#if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040
/* Support for weakly importing pthread_atfork. */
#define WEAK_IMPORT_PTHREAD_ATFORK
extern int pthread_atfork(void (*prepare)(void), void (*parent)(void),
void (*child)(void)) WEAK_IMPORT_ATTRIBUTE;
#endif /* HAVE_WEAK_IMPORT */
#endif /* HAVE_PTHREAD_ATFORK */
/*
*----------------------------------------------------------------------
*
* Tcl_InitNotifier --
*
* Initializes the platform specific notifier state.
*
* Results:
* Returns a handle to the notifier state for this thread.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_InitNotifier(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->eventReady = 0;
#ifdef WEAK_IMPORT_SPINLOCKLOCK
/*
* Initialize support for weakly imported spinlock API.
*/
if (pthread_once(&spinLockLockInitControl, SpinLockLockInit)) {
Tcl_Panic("Tcl_InitNotifier: pthread_once failed");
}
#endif
#ifndef __CONSTANT_CFSTRINGS__
if (!tclEventsOnlyRunLoopMode) {
tclEventsOnlyRunLoopMode = CFSTR(TCL_EVENTS_ONLY_RUN_LOOP_MODE);
}
#endif
/*
* Initialize CFRunLoopSource and add it to CFRunLoop of this thread.
*/
if (!tsdPtr->runLoop) {
CFRunLoopRef runLoop = CFRunLoopGetCurrent();
CFRunLoopSourceRef runLoopSource;
CFRunLoopSourceContext runLoopSourceContext;
bzero(&runLoopSourceContext, sizeof(CFRunLoopSourceContext));
runLoopSourceContext.info = tsdPtr;
runLoopSource = CFRunLoopSourceCreate(NULL, 0, &runLoopSourceContext);
if (!runLoopSource) {
Tcl_Panic("Tcl_InitNotifier: could not create CFRunLoopSource");
}
CFRunLoopAddSource(runLoop, runLoopSource, kCFRunLoopCommonModes);
CFRunLoopAddSource(runLoop, runLoopSource, tclEventsOnlyRunLoopMode);
tsdPtr->runLoopSource = runLoopSource;
tsdPtr->runLoop = runLoop;
}
LOCK_NOTIFIER_INIT;
#ifdef HAVE_PTHREAD_ATFORK
/*
* Install pthread_atfork handlers to reinitialize the notifier in the
* child of a fork.
*/
if (
#ifdef WEAK_IMPORT_PTHREAD_ATFORK
pthread_atfork != NULL &&
#endif
!atForkInit) {
int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild);
if (result) {
Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed");
}
atForkInit = 1;
}
#endif
if (notifierCount == 0) {
int fds[2], status;
/*
* Initialize trigger pipe.
*/
if (pipe(fds) != 0) {
Tcl_Panic("Tcl_InitNotifier: could not create trigger pipe");
}
status = fcntl(fds[0], F_GETFL);
status |= O_NONBLOCK;
if (fcntl(fds[0], F_SETFL, status) < 0) {
Tcl_Panic("Tcl_InitNotifier: could not make receive pipe non blocking");
}
status = fcntl(fds[1], F_GETFL);
status |= O_NONBLOCK;
if (fcntl(fds[1], F_SETFL, status) < 0) {
Tcl_Panic("Tcl_InitNotifier: could not make trigger pipe non blocking");
}
receivePipe = fds[0];
triggerPipe = fds[1];
/*
* Create notifier thread lazily in Tcl_WaitForEvent() to avoid
* interfering with fork() followed immediately by execve()
* (cannot execve() when more than one thread is present).
*/
notifierThread = 0;
}
notifierCount++;
UNLOCK_NOTIFIER_INIT;
return (ClientData) tsdPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FinalizeNotifier --
*
* This function is called to cleanup the notifier state before a thread
* is terminated.
*
* Results:
* None.
*
* Side effects:
* May terminate the background notifier thread if this is the last
* notifier instance.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeNotifier(
ClientData clientData) /* Not used. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
LOCK_NOTIFIER_INIT;
notifierCount--;
/*
* If this is the last thread to use the notifier, close the notifier pipe
* and wait for the background thread to terminate.
*/
if (notifierCount == 0) {
int result;
if (triggerPipe < 0) {
Tcl_Panic("Tcl_FinalizeNotifier: notifier pipe not initialized");
}
/*
* Send "q" message to the notifier thread so that it will terminate.
* The notifier will return from its call to select() and notice that
* a "q" message has arrived, it will then close its side of the pipe
* and terminate its thread. Note the we can not just close the pipe
* and check for EOF in the notifier thread because if a background
* child process was created with exec, select() would not register
* the EOF on the pipe until the child processes had terminated. [Bug:
* 4139] [Bug: 1222872]
*/
write(triggerPipe, "q", 1);
close(triggerPipe);
if (notifierThread) {
result = pthread_join(notifierThread, NULL);
if (result) {
Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread");
}
notifierThread = 0;
}
close(receivePipe);
triggerPipe = -1;
}
UNLOCK_NOTIFIER_INIT;
LOCK_NOTIFIER; /* for concurrency with Tcl_AlertNotifier */
if (tsdPtr->runLoop) {
tsdPtr->runLoop = NULL;
/*
* Remove runLoopSource from all CFRunLoops and release it.
*/
CFRunLoopSourceInvalidate(tsdPtr->runLoopSource);
CFRelease(tsdPtr->runLoopSource);
tsdPtr->runLoopSource = NULL;
}
UNLOCK_NOTIFIER;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AlertNotifier --
*
* Wake up the specified notifier from any thread. This routine is called
* by the platform independent notifier code whenever the Tcl_ThreadAlert
* routine is called. This routine is guaranteed not to be called on a
* given notifier after Tcl_FinalizeNotifier is called for that notifier.
*
* Results:
* None.
*
* Side effects:
* Signals the notifier condition variable for the specified notifier.
*
*----------------------------------------------------------------------
*/
void
Tcl_AlertNotifier(
ClientData clientData)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
LOCK_NOTIFIER;
if (tsdPtr->runLoop) {
tsdPtr->eventReady = 1;
CFRunLoopSourceSignal(tsdPtr->runLoopSource);
CFRunLoopWakeUp(tsdPtr->runLoop);
}
UNLOCK_NOTIFIER;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetTimer --
*
* This function sets the current notifier timer value. This interface is
* not implemented in this notifier because we are always running inside
* of Tcl_DoOneEvent.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetTimer(
Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
/*
* The interval timer doesn't do anything in this implementation, because
* the only event loop is via Tcl_DoOneEvent, which passes timeout values
* to Tcl_WaitForEvent.
*/
if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
tclStubs.tcl_SetTimer(timePtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ServiceModeHook --
*
* This function is invoked whenever the service mode changes.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_ServiceModeHook(
int mode) /* Either TCL_SERVICE_ALL, or
* TCL_SERVICE_NONE. */
{
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateFileHandler --
*
* This function registers a file handler with the select notifier.
*
* Results:
* None.
*
* Side effects:
* Creates a new file handler structure.
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateFileHandler(
int fd, /* Handle of stream to watch. */
int mask, /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, and TCL_EXCEPTION: indicates
* conditions under which proc should be
* called. */
Tcl_FileProc *proc, /* Function to call for each selected
* event. */
ClientData clientData) /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr;
if (tclStubs.tcl_CreateFileHandler !=
tclOriginalNotifier.createFileHandlerProc) {
tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData);
return;
}
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler*) ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
}
filePtr->proc = proc;
filePtr->clientData = clientData;
filePtr->mask = mask;
/*
* Update the check masks for this file.
*/
if (mask & TCL_READABLE) {
FD_SET(fd, &(tsdPtr->checkMasks.readable));
} else {
FD_CLR(fd, &(tsdPtr->checkMasks.readable));
}
if (mask & TCL_WRITABLE) {
FD_SET(fd, &(tsdPtr->checkMasks.writable));
} else {
FD_CLR(fd, &(tsdPtr->checkMasks.writable));
}
if (mask & TCL_EXCEPTION) {
FD_SET(fd, &(tsdPtr->checkMasks.exceptional));
} else {
FD_CLR(fd, &(tsdPtr->checkMasks.exceptional));
}
if (tsdPtr->numFdBits <= fd) {
tsdPtr->numFdBits = fd+1;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteFileHandler --
*
* Cancel a previously-arranged callback arrangement for a file.
*
* Results:
* None.
*
* Side effects:
* If a callback was previously registered on file, remove it.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteFileHandler(
int fd) /* Stream id for which to remove callback
* function. */
{
FileHandler *filePtr, *prevPtr;
int i;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tclStubs.tcl_DeleteFileHandler !=
tclOriginalNotifier.deleteFileHandlerProc) {
tclStubs.tcl_DeleteFileHandler(fd);
return;
}
/*
* Find the entry for the given file (and return if there isn't one).
*/
for (prevPtr = NULL, filePtr = tsdPtr->firstFileHandlerPtr; ;
prevPtr = filePtr, filePtr = filePtr->nextPtr) {
if (filePtr == NULL) {
return;
}
if (filePtr->fd == fd) {
break;
}
}
/*
* Update the check masks for this file.
*/
if (filePtr->mask & TCL_READABLE) {
FD_CLR(fd, &(tsdPtr->checkMasks.readable));
}
if (filePtr->mask & TCL_WRITABLE) {
FD_CLR(fd, &(tsdPtr->checkMasks.writable));
}
if (filePtr->mask & TCL_EXCEPTION) {
FD_CLR(fd, &(tsdPtr->checkMasks.exceptional));
}
/*
* Find current max fd.
*/
if (fd+1 == tsdPtr->numFdBits) {
tsdPtr->numFdBits = 0;
for (i = fd-1; i >= 0; i--) {
if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))
|| FD_ISSET(i, &(tsdPtr->checkMasks.writable))
|| FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) {
tsdPtr->numFdBits = i+1;
break;
}
}
}
/*
* Clean up information in the callback record.
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
ckfree((char *) filePtr);
}
/*
*----------------------------------------------------------------------
*
* FileHandlerEventProc --
*
* This function is called by Tcl_ServiceEvent when a file event reaches
* the front of the event queue. This function is responsible for
* actually handling the event by invoking the callback for the file
* handler.
*
* Results:
* Returns 1 if the event was handled, meaning it should be removed from
* the queue. Returns 0 if the event was not handled, meaning it should
* stay on the queue. The only time the event isn't handled is if the
* TCL_FILE_EVENTS flag bit isn't set.
*
* Side effects:
* Whatever the file handler's callback function does.
*
*----------------------------------------------------------------------
*/
static int
FileHandlerEventProc(
Tcl_Event *evPtr, /* Event to service. */
int flags) /* Flags that indicate what events to handle,
* such as TCL_FILE_EVENTS. */
{
int mask;
FileHandler *filePtr;
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
ThreadSpecificData *tsdPtr;
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
}
/*
* Search through the file handlers to find the one whose handle matches
* the event. We do this rather than keeping a pointer to the file handler
* directly in the event, so that the handler can be deleted while the
* event is queued without leaving a dangling pointer.
*/
tsdPtr = TCL_TSD_INIT(&dataKey);
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd != fileEvPtr->fd) {
continue;
}
/*
* The code is tricky for two reasons:
* 1. The file handler's desired events could have changed since the
* time when the event was queued, so AND the ready mask with the
* desired mask.
* 2. The file could have been closed and re-opened since the time
* when the event was queued. This is why the ready mask is stored
* in the file handler rather than the queued event: it will be
* zeroed when a new file handler is created for the newly opened
* file.
*/
mask = filePtr->readyMask & filePtr->mask;
filePtr->readyMask = 0;
if (mask != 0) {
(*filePtr->proc)(filePtr->clientData, mask);
}
break;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_WaitForEvent --
*
* This function is called by Tcl_DoOneEvent to wait for new events on
* the message queue. If the block time is 0, then Tcl_WaitForEvent just
* polls without blocking.
*
* Results:
* Returns -1 if the select would block forever, otherwise returns 0.
*
* Side effects:
* Queues file events that are detected by the select.
*
*----------------------------------------------------------------------
*/
int
Tcl_WaitForEvent(
Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
FileHandler *filePtr;
FileHandlerEvent *fileEvPtr;
int mask;
int waitForFiles;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
return tclStubs.tcl_WaitForEvent(timePtr);
}
/*
* Start notifier thread if necessary.
*/
LOCK_NOTIFIER_INIT;
if (!notifierCount) {
Tcl_Panic("Tcl_WaitForEvent: notifier not initialized");
}
if (!notifierThread) {
int result;
pthread_attr_t attr;
pthread_attr_init(&attr);
pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_JOINABLE);
pthread_attr_setstacksize(&attr, 60 * 1024);
result = pthread_create(¬ifierThread, &attr,
(void * (*)(void *))NotifierThreadProc, NULL);
pthread_attr_destroy(&attr);
if (result || !notifierThread) {
Tcl_Panic("Tcl_WaitForEvent: unable to start notifier thread");
}
}
UNLOCK_NOTIFIER_INIT;
/*
* Place this thread on the list of interested threads, signal the
* notifier thread, and wait for a response or a timeout.
*/
LOCK_NOTIFIER;
if (!tsdPtr->runLoop) {
Tcl_Panic("Tcl_WaitForEvent: CFRunLoop not initialized");
}
waitForFiles = (tsdPtr->numFdBits > 0);
if (timePtr != NULL && timePtr->sec == 0 && timePtr->usec == 0) {
/*
* Cannot emulate a polling select with a polling condition variable.
* Instead, pretend to wait for files and tell the notifier thread
* what we are doing. The notifier thread makes sure it goes through
* select with its select mask in the same state as ours currently is.
* We block until that happens.
*/
waitForFiles = 1;
tsdPtr->pollState = POLL_WANT;
timePtr = NULL;
} else {
tsdPtr->pollState = 0;
}
if (waitForFiles) {
/*
* Add the ThreadSpecificData structure of this thread to the list of
* ThreadSpecificData structures of all threads that are waiting on
* file events.
*/
tsdPtr->nextPtr = waitingListPtr;
if (waitingListPtr) {
waitingListPtr->prevPtr = tsdPtr;
}
tsdPtr->prevPtr = 0;
waitingListPtr = tsdPtr;
tsdPtr->onList = 1;
write(triggerPipe, "", 1);
}
FD_ZERO(&(tsdPtr->readyMasks.readable));
FD_ZERO(&(tsdPtr->readyMasks.writable));
FD_ZERO(&(tsdPtr->readyMasks.exceptional));
if (!tsdPtr->eventReady) {
CFTimeInterval waitTime;
CFStringRef runLoopMode;
if (timePtr == NULL) {
waitTime = 1.0e10; /* Wait forever, as per CFRunLoop.c */
} else {
waitTime = timePtr->sec + 1.0e-6 * timePtr->usec;
}
/*
* If the run loop is already running (e.g. if Tcl_WaitForEvent was
* called recursively), re-run it in a custom run loop mode containing
* only the source for the notifier thread, otherwise wakeups from other
* sources added to the common run loop modes might get lost.
*/
if ((runLoopMode = CFRunLoopCopyCurrentMode(tsdPtr->runLoop))) {
CFRelease(runLoopMode);
runLoopMode = tclEventsOnlyRunLoopMode;
} else {
runLoopMode = kCFRunLoopDefaultMode;
}
UNLOCK_NOTIFIER;
CFRunLoopRunInMode(runLoopMode, waitTime, TRUE);
LOCK_NOTIFIER;
}
tsdPtr->eventReady = 0;
if (waitForFiles && tsdPtr->onList) {
/*
* Remove the ThreadSpecificData structure of this thread from the
* waiting list. Alert the notifier thread to recompute its select
* masks - skipping this caused a hang when trying to close a pipe
* which the notifier thread was still doing a select on.
*/
if (tsdPtr->prevPtr) {
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
waitingListPtr = tsdPtr->nextPtr;
}
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
write(triggerPipe, "", 1);
}
/*
* Queue all detected file events before returning.
*/
for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL);
filePtr = filePtr->nextPtr) {
mask = 0;
if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.readable))) {
mask |= TCL_READABLE;
}
if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.writable))) {
mask |= TCL_WRITABLE;
}
if (FD_ISSET(filePtr->fd, &(tsdPtr->readyMasks.exceptional))) {
mask |= TCL_EXCEPTION;
}
if (!mask) {
continue;
}
/*
* Don't bother to queue an event if the mask was previously non-zero
* since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
}
UNLOCK_NOTIFIER;
return 0;
}
/*
*----------------------------------------------------------------------
*
* NotifierThreadProc --
*
* This routine is the initial (and only) function executed by the
* special notifier thread. Its job is to wait for file descriptors to
* become readable or writable or to have an exception condition and then
* to notify other threads who are interested in this information by
* signalling a condition variable. Other threads can signal this
* notifier thread of a change in their interests by writing a single
* byte to a special pipe that the notifier thread is monitoring.
*
* Result:
* None. Once started, this routine never exits. It dies with the overall
* process.
*
* Side effects:
* The trigger pipe used to signal the notifier thread is created when
* the notifier thread first starts.
*
*----------------------------------------------------------------------
*/
static void
NotifierThreadProc(
ClientData clientData) /* Not used. */
{
ThreadSpecificData *tsdPtr;
fd_set readableMask;
fd_set writableMask;
fd_set exceptionalMask;
int i, numFdBits = 0;
long found;
struct timeval poll = {0., 0.}, *timePtr;
char buf[2];
/*
* Look for file events and report them to interested threads.
*/
while (1) {
FD_ZERO(&readableMask);
FD_ZERO(&writableMask);
FD_ZERO(&exceptionalMask);
/*
* Compute the logical OR of the select masks from all the waiting
* notifiers.
*/
LOCK_NOTIFIER;
timePtr = NULL;
for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))) {
FD_SET(i, &readableMask);
}
if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))) {
FD_SET(i, &writableMask);
}
if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))) {
FD_SET(i, &exceptionalMask);
}
}
if (tsdPtr->numFdBits > numFdBits) {
numFdBits = tsdPtr->numFdBits;
}
if (tsdPtr->pollState & POLL_WANT) {
/*
* Here we make sure we go through select() with the same mask
* bits that were present when the thread tried to poll.
*/
tsdPtr->pollState |= POLL_DONE;
timePtr = &poll;
}
}
UNLOCK_NOTIFIER;
/*
* Set up the select mask to include the receive pipe.
*/
if (receivePipe >= numFdBits) {
numFdBits = receivePipe + 1;
}
FD_SET(receivePipe, &readableMask);
if (select(numFdBits, &readableMask, &writableMask, &exceptionalMask,
timePtr) == -1) {
/*
* Try again immediately on an error.
*/
continue;
}
/*
* Alert any threads that are waiting on a ready file descriptor.
*/
LOCK_NOTIFIER;
for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
found = 0;
for (i = tsdPtr->numFdBits-1; i >= 0; --i) {
if (FD_ISSET(i, &(tsdPtr->checkMasks.readable))
&& FD_ISSET(i, &readableMask)) {
FD_SET(i, &(tsdPtr->readyMasks.readable));
found = 1;
}
if (FD_ISSET(i, &(tsdPtr->checkMasks.writable))
&& FD_ISSET(i, &writableMask)) {
FD_SET(i, &(tsdPtr->readyMasks.writable));
found = 1;
}
if (FD_ISSET(i, &(tsdPtr->checkMasks.exceptional))
&& FD_ISSET(i, &exceptionalMask)) {
FD_SET(i, &(tsdPtr->readyMasks.exceptional));
found = 1;
}
}
if (found || (tsdPtr->pollState & POLL_DONE)) {
tsdPtr->eventReady = 1;
if (tsdPtr->onList) {
/*
* Remove the ThreadSpecificData structure of this thread
* from the waiting list. This prevents us from
* continuously spining on select until the other threads
* runs and services the file event.
*/
if (tsdPtr->prevPtr) {
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
waitingListPtr = tsdPtr->nextPtr;
}
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
tsdPtr->pollState = 0;
}
if (tsdPtr->runLoop) {
CFRunLoopSourceSignal(tsdPtr->runLoopSource);
CFRunLoopWakeUp(tsdPtr->runLoop);
}
}
}
UNLOCK_NOTIFIER;
/*
* Consume the next byte from the notifier pipe if the pipe was
* readable. Note that there may be multiple bytes pending, but to
* avoid a race condition we only read one at a time.
*/
if (FD_ISSET(receivePipe, &readableMask)) {
i = read(receivePipe, buf, 1);
if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) {
/*
* Someone closed the write end of the pipe or sent us a Quit
* message [Bug: 4139] and then closed the write end of the
* pipe so we need to shut down the notifier thread.
*/
break;
}
}
}
pthread_exit(0);
}
#ifdef HAVE_PTHREAD_ATFORK
/*
*----------------------------------------------------------------------
*
* AtForkPrepare --
*
* Lock the notifier in preparation for a fork.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
AtForkPrepare(void)
{
LOCK_NOTIFIER_INIT;
LOCK_NOTIFIER;
}
/*
*----------------------------------------------------------------------
*
* AtForkParent --
*
* Unlock the notifier in the parent after a fork.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
AtForkParent(void)
{
UNLOCK_NOTIFIER;
UNLOCK_NOTIFIER_INIT;
}
/*
*----------------------------------------------------------------------
*
* AtForkChild --
*
* Unlock and reinstall the notifier in the child after a fork.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
AtForkChild(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
UNLOCK_NOTIFIER;
UNLOCK_NOTIFIER_INIT;
if (tsdPtr->runLoop) {
tsdPtr->runLoop = NULL;
CFRunLoopSourceInvalidate(tsdPtr->runLoopSource);
CFRelease(tsdPtr->runLoopSource);
tsdPtr->runLoopSource = NULL;
}
if (notifierCount > 0) {
notifierCount = 0;
/*
* Assume that the return value of Tcl_InitNotifier in the child will
* be identical to the one stored as clientData in tclNotify.c's
* ThreadSpecificData by the parent's TclInitNotifier, so discard the
* return value here. This assumption may require the fork() to be
* executed in the main thread of the parent, otherwise
* Tcl_AlertNotifier may break in the child.
*/
Tcl_InitNotifier();
}
}
#endif /* HAVE_PTHREAD_ATFORK */
#endif /* HAVE_COREFOUNDATION */
|
Changes to tests/README.
1 2 | README -- Tcl test suite design document. | | > > | | > > > | | | < > > > > | < | | > > | < > | | > | > > | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
README -- Tcl test suite design document.
RCS: @(#) $Id: README,v 1.11.2.1 2003/04/01 21:13:07 dgp Exp $
Contents:
---------
1. Introduction
2. Running tests
3. Adding tests
4. Incompatibilities with prior Tcl versions
1. Introduction:
----------------
This directory contains a set of validation tests for the Tcl commands
and C Library procedures for Tcl. Each of the files whose name ends
in ".test" is intended to fully exercise the functions in the C source
file that corresponds to the file prefix. The C functions and/or Tcl
commands tested by a given file are listed in the first line of the
file.
2. Running tests:
-----------------
We recommend that you use the "test" target of Tcl's Makefile to run
the test suite. From the directory in which you build Tcl, simply
type "make test". This will create a special executable named
tcltest in which the testing scripts will be evaluated. To create
the tcltest executable without running the test suite, simple type
"make tcltest".
All the configuration options of the tcltest package are available
during a "make test" by defining the TESTFLAGS environment variable.
For example,if you wish to run only those tests in the file append.test,
you can type:
make test TESTFLAGS="-file append.test"
For interactive testing, the Tcl Makefile provides the "runtest" target.
Type "make runtest" in your build directory, and the tcltest executable
will be created, if necessary, then it will run interactively. At the
command prompt, you may type any Tcl commands. If you type
"source ../tests/all.tcl", the test suite will run. You may use the
tcltest::configure command to configure the test suite run as an
alternative to command line options via TESTFLAGS. You might also
wish to use the tcltest::testConstraint command to select the constraints
that govern which tests are run. See the documentation for the tcltest
package for details.
3. Adding tests:
----------------
Please see the tcltest man page for more information regarding how to
write and run tests.
Please note that the all.tcl file will source your new test file if
the filename matches the tests/*.test pattern (as it should). The
names of test files that contain regression (or glass-box) tests
|
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | properly to be sure of this. Be sure your tests can run cross-platform in both a build environment as well as an installation environment. If your test file contains tests that should not be run in one or more of those cases, please use the constraints mechanism to skip those tests. | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | properly to be sure of this. Be sure your tests can run cross-platform in both a build environment as well as an installation environment. If your test file contains tests that should not be run in one or more of those cases, please use the constraints mechanism to skip those tests. 4. Incompatibilities of package tcltest 2.1 with testing machinery of very old versions of Tcl: ------------------------------------------------ 1) Global variables such as VERBOSE, TESTS, and testConfig of the old machinery correspond to the [configure -verbose], [configure -match], and [testConstraint] commands of tcltest 2.1, respectively. |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | 5) The "defs" and "defs.tcl" files no longer exist. 6) Instead of creating a doAllTests file in the tests directory, to run all nonPortable tests, just use the "-constraints nonPortable" command line flag. If you are running interactively, you can run [tcltest::testConstraint nonPortable 1] (after loading the tcltest package). | > > > > > | 98 99 100 101 102 103 104 105 106 107 108 109 | 5) The "defs" and "defs.tcl" files no longer exist. 6) Instead of creating a doAllTests file in the tests directory, to run all nonPortable tests, just use the "-constraints nonPortable" command line flag. If you are running interactively, you can run [tcltest::testConstraint nonPortable 1] (after loading the tcltest package). 7) Direct evaluation of the *.test files by the "source" command is no longer recommended. Instead, "source all.tcl" and use the "-file" and "-notfile" options of tcltest::configure to control which *.test files are evaluated. |
Changes to tests/append.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: append lappend # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: append lappend
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: append.test,v 1.7.12.1 2006/10/05 11:44:04 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset x}
|
| ︙ | ︙ | |||
139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
catch {unset x}
lappend x(0)
} {}
test append-4.20 {lappend command} {
catch {unset x}
lappend x(0) abc
} {abc}
proc check {var size} {
set l [llength $var]
if {$l != $size} {
return "length mismatch: should have been $size, was $l"
}
for {set i 0} {$i < $size} {set i [expr $i+1]} {
| > > > > > > > > > | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
catch {unset x}
lappend x(0)
} {}
test append-4.20 {lappend command} {
catch {unset x}
lappend x(0) abc
} {abc}
unset x
test append-4.21 {lappend command} {
set x \"
list [catch {lappend x} msg] $msg
} {1 {unmatched open quote in list}}
test append-4.22 {lappend command} {
set x \"
list [catch {lappend x abc} msg] $msg
} {1 {unmatched open quote in list}}
proc check {var size} {
set l [llength $var]
if {$l != $size} {
return "length mismatch: should have been $size, was $l"
}
for {set i 0} {$i < $size} {set i [expr $i+1]} {
|
| ︙ | ︙ |
Changes to tests/appendComp.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: append lappend # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: append lappend
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: appendComp.test,v 1.5.4.1 2004/10/28 00:01:05 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset x}
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
proc foo {} { lappend x }
foo
} {}
test appendComp-4.18 {lappend command} {
proc foo {} { lappend x {} }
foo
} {{}}
| | | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
proc foo {} { lappend x }
foo
} {}
test appendComp-4.18 {lappend command} {
proc foo {} { lappend x {} }
foo
} {{}}
test appendComp-4.19 {lappend command} {
proc foo {} { lappend x(0) }
foo
} {}
test appendComp-4.20 {lappend command} {
proc foo {} { lappend x(0) abc }
foo
} {abc}
proc check {var size} {
set l [llength $var]
if {$l != $size} {
|
| ︙ | ︙ |
Changes to tests/autoMkindex.test.
1 2 3 4 5 6 7 8 9 10 11 | # Commands covered: auto_mkindex auto_import # # This file contains tests related to autoloading and generating # the autoloading index. # # Copyright (c) 1998 Lucent Technologies, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# Commands covered: auto_mkindex auto_import
#
# This file contains tests related to autoloading and generating
# the autoloading index.
#
# Copyright (c) 1998 Lucent Technologies, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: autoMkindex.test,v 1.14.2.1 2004/10/28 00:01:06 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
makeFile {# Test file for:
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
makeFile {
proc {[magic mojo proc]} {} {}
} [file join pkg magicchar2.tcl]
test autoMkindex-5.2 {correctly locate auto loaded procs with []} {
file delete tclIndex
| | | | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
makeFile {
proc {[magic mojo proc]} {} {}
} [file join pkg magicchar2.tcl]
test autoMkindex-5.2 {correctly locate auto loaded procs with []} {
file delete tclIndex
set result {}
if { ![catch {auto_mkindex . pkg/magicchar2.tcl}] } {
# Make a slave interp to test the autoloading
set c [interp create]
$c eval {lappend auto_path [pwd]}
set result [$c eval {catch {{[magic mojo proc]}}}]
interp delete $c
}
set result
} 0
removeFile [file join pkg magicchar2.tcl]
removeDirectory pkg
# Clean up.
|
| ︙ | ︙ |
Changes to tests/basic.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: basic.test,v 1.25.2.7 2005/03/18 16:33:43 dgp Exp $
#
package require tcltest 2
namespace import -force ::tcltest::*
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint testevalex [llength [info commands testevalex]]
testConstraint exec [llength [info commands exec]]
# This variable needs to be changed when the major or minor version number for
# Tcl changes.
set tclvers 8.4
catch {namespace delete test_ns_basic}
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
return [namespace current]
}
}
}
list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
[catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
[interp delete test_interp]
| | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
return [namespace current]
}
}
}
list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
[catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
[interp delete test_interp]
} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers in hidden command token (rename)} {}}
test basic-12.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
catch {namespace delete test_ns_basic}
catch {rename cmd ""}
proc cmd {} { ;# note that this is global
return [namespace current]
}
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 433 434 435 436 437 438 439 |
set x {}
vwait x
close $f
removeFile test1
rename bgerror {}
set x
} "foo\n while executing\n\"error foo\""
test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}
test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
} {}
| > > > > > > > > > > > > > > > > > > | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
set x {}
vwait x
close $f
removeFile test1
rename bgerror {}
set x
} "foo\n while executing\n\"error foo\""
test basic-26.2 {Tcl_EvalObjEx, pure-list branch: preserve "objv"} {
#
# Follow the pure-list branch in a manner that
# a - the pure-list internal rep is destroyed by shimmering
# b - the command returns an error
# As the error code in Tcl_EvalObjv accesses the list elements, this will
# cause a segfault if [Bug 1119369] has not been fixed.
#
set SRC [list foo 1] ;# pure-list command
proc foo str {
# Shimmer pure-list to cmdName, cleanup and error
proc $::SRC {} {}; $::SRC
error "BAD CALL"
}
catch {eval $SRC}
} 1
test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}
test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
} {}
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
test basic-39.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} {
proc OtherStatus { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result]
} {6 {}}
test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
# the above tests have tested Tcl_DeleteTrace
} {}
test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
} {}
| > > > > > > > > > | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
test basic-39.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} {
proc OtherStatus { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result]
} {6 {}}
test basic-39.10 {Tcl_CreateTrace, correct level interpretation} {testcmdtrace} {
proc foo {} {uplevel 1 bar}
proc bar {} {uplevel 1 grok}
proc grok {} {uplevel 1 spock}
proc spock {} {uplevel 1 fascinating}
proc fascinating {} {}
testcmdtrace leveltest {foo}
} {foo {foo} {uplevel 1 bar} {uplevel 1 bar} bar {bar} {uplevel 1 grok} {uplevel 1 grok}}
test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
# the above tests have tested Tcl_DeleteTrace
} {}
test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
} {}
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
append msg "${newMsg}\n"
}
close $f
} error]
list $res $msg
} {1 {invoked "continue" outside of a loop
while executing
| | < | > > > | > < < | | | > > > | > < < | | | > > > | > < < | | < < | | | > > > | > < < | | > > > > > > > > > > > > > > > > > > > | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 |
append msg "${newMsg}\n"
}
close $f
} error]
list $res $msg
} {1 {invoked "continue" outside of a loop
while executing
"continue"
DONE
}}
test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
puts hello
break
} BREAKtest]
} -constraints {
exec
} -body {
exec [interpreter] $fName
} -cleanup {
removeFile BREAKtest
} -returnCodes error -match glob -result {hello
invoked "break" outside of a loop
while executing
"break"
(file "*BREAKtest" line 3)}
test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
interp alias {} patch {} info patchlevel
patch
break
} BREAKtest]
} -constraints {
exec
} -body {
exec [interpreter] $fName
} -cleanup {
removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
while executing
"break"
(file "*BREAKtest" line 4)}
test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
foo [set a 1] [break]
} BREAKtest]
} -constraints {
exec
} -body {
exec [interpreter] $fName
} -cleanup {
removeFile BREAKtest
} -returnCodes error -match glob -result {invoked "break" outside of a loop
while executing*
"foo \[set a 1] \[break]"
(file "*BREAKtest" line 2)}
test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup {
set fName [makeFile {
return -code return
} BREAKtest]
} -constraints {
exec
} -body {
exec [interpreter] $fName
} -cleanup {
removeFile BREAKtest
} -returnCodes error -match glob -result {command returned bad code: 2
while executing
"return -code return"
(file "*BREAKtest" line 2)}
test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body {
subst {a[set b [format cd]}
} -returnCodes error -result {missing close-bracket}
test basic-49.1 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
set ::x global
namespace eval ns {
variable x namespace
testevalex {set x changed} global
set ::result [list $::x $x]
}
namespace delete ns
set ::result
} {changed namespace}
test basic-49.2 {Tcl_EvalEx: verify TCL_EVAL_GLOBAL operation} testevalex {
set ::x global
namespace eval ns {
variable x namespace
testevalex {set ::context $x} global
}
namespace delete ns
set ::context
} {global}
# cleanup
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {namespace delete george}
catch {interp delete test_interp}
catch {rename p ""}
catch {rename q ""}
catch {rename cmd ""}
catch {rename value:at: ""}
catch {unset x}
::tcltest::cleanupTests
return
|
Changes to tests/binary.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclBinary.c file and the "binary" Tcl command. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclBinary.c file and the "binary" Tcl command.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: binary.test,v 1.11.2.4 2006/04/05 15:17:06 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test binary-0.1 {DupByteArrayInternalRep} {
|
| ︙ | ︙ | |||
528 529 530 531 532 533 534 535 536 537 538 539 540 541 |
set a {1.6 3.4}
binary format d1 $a
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-14.17 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
set a {1.6 3.4}
binary format d1 $a
} \x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-15.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format ax*a "y" "z"} msg] $msg
} {1 {cannot use "*" in format string with "x"}}
test binary-15.2 {Tcl_BinaryObjCmd: format} {
binary format axa "y" "z"
} y\x00z
| > > > > | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
set a {1.6 3.4}
binary format d1 $a
} \x3f\xf9\x99\x99\x99\x99\x99\x9a
test binary-14.17 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
set a {1.6 3.4}
binary format d1 $a
} \x9a\x99\x99\x99\x99\x99\xf9\x3f
test binary-14.18 {FormatNumber: Bug 1116542} {
binary scan [binary format d 1.25] d w
set w
} 1.25
test binary-15.1 {Tcl_BinaryObjCmd: format} {
list [catch {binary format ax*a "y" "z"} msg] $msg
} {1 {cannot use "*" in format string with "x"}}
test binary-15.2 {Tcl_BinaryObjCmd: format} {
binary format axa "y" "z"
} y\x00z
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 |
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
catch {unset arg1; unset arg2}
list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}
test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} {} {
| | | | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 |
} {2 1 1.6}
test binary-41.8 {ScanNumber: word alignment} {nonPortable pcOnly} {
catch {unset arg1; unset arg2}
list [binary scan \x01\x9a\x99\x99\x99\x99\x99\xf9\x3f c1d1 arg1 arg2] $arg1 $arg2
} {2 1 1.6}
test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} {} {
catch {binary ?} result
set result
} {bad option "?": must be format or scan}
# Wide int (guaranteed at least 64-bit) handling
test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} {
binary format w 7810179016327718216
} HelloTcl
test binary-43.2 {Tcl_BinaryObjCmd: format wide int} {} {
binary format W 7810179016327718216
|
| ︙ | ︙ | |||
1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 |
binary scan [binary format sws 16450 -1 19521] c* x
set x
} {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76}
test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} {
binary scan [binary format sWs 16450 0x7fffffff 19521] c* x
set x
} {66 64 0 0 0 0 127 -1 -1 -1 65 76}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 |
binary scan [binary format sws 16450 -1 19521] c* x
set x
} {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76}
test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} {
binary scan [binary format sWs 16450 0x7fffffff 19521] c* x
set x
} {66 64 0 0 0 0 127 -1 -1 -1 65 76}
test binary-46.1 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
binary format a* \u20ac
} \u00ac
test binary-46.2 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
list [binary scan [binary format a* \u20ac\u20bd] s x] $x
} {1 -16980}
test binary-46.3 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
set x {}
set y {}
set z {}
list [binary scan [binary format a* \u20ac\u20bd] aaa x y z] $x $y $z
} "2 \u00ac \u00bd {}"
test binary-46.4 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
set x [encoding convertto iso8859-15 \u20ac]
set y [binary format a* $x]
list $x $y
} "\u00a4 \u00a4"
test binary-46.5 {Tcl_BinaryObjCmd: handling of non-ISO8859-1 chars} {
set x [binary scan \u00a4 a* y]
list $x $y [encoding convertfrom iso8859-15 $y]
} "1 \u00a4 \u20ac"
test binary-47.1 {Tcl_BinaryObjCmd: number cache reference count handling} {
# This test is only reliable when memory debugging is turned on,
# but without even memory debugging it should still generate the
# expected answers and might therefore still pick up memory corruption
# caused by [Bug 851747].
list [binary scan aba ccc x x x] $x
} {3 97}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/clock.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: clock # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1998 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: clock
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: clock.test,v 1.22.2.7 2006/07/30 17:05:43 kennykb Exp $
set env(LC_TIME) POSIX
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
} {1 {bad switch "-": must be -milliseconds}}
# clock format
test clock-3.1 {clock format tests} {unixOnly} {
set clockval 657687766
clock format $clockval -format {%a %b %d %I:%M:%S %p %Y} -gmt true
} {Sun Nov 04 03:02:46 AM 1990}
| | > | | | | | | | | | | > > | > | | > | | | | < | | | > > | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
} {1 {bad switch "-": must be -milliseconds}}
# clock format
test clock-3.1 {clock format tests} {unixOnly} {
set clockval 657687766
clock format $clockval -format {%a %b %d %I:%M:%S %p %Y} -gmt true
} {Sun Nov 04 03:02:46 AM 1990}
test clock-3.2 {clock format tests} \
-body {
# TCL_USE_TIMEZONE_VAR
catch {set oldtz $env(TZ)}
set env(TZ) PST
set x {}
append x [clock format 863800000 -format %Z -gmt 1]
append x [set env(TZ)]
catch {unset env(TZ); set env(TZ) $oldtz}
set x
} \
-match regexp \
-result {(?:GMT|UTC)PST}
test clock-3.3 {clock format tests} {
# tzset() under Borland doesn't seem to set up tzname[] for local
# timezone, which caused "clock format" to think that %Z was an invalid
# string. Don't care about answer, just that test runs w/o error.
clock format 863800000 -format %Z
set x {}
} {}
test clock-3.4 {clock format tests} \
-body {
# tzset() under Borland doesn't seem to set up tzname[] for gmt
# timezone. tzset() under MSVC has the following weird observed
# behavior:
# First time we call "clock format [clock seconds] -format %Z -gmt 1"
# we get "GMT", but on all subsequent calls we get the current time
# zone string, even though env(TZ) is GMT and the variable _timezone
# is 0.
set x {}
append x [clock format 863800000 -format %Z -gmt 1]
append x [clock format 863800000 -format %Z -gmt 1]
} \
-match regexp \
-result {GMTGMT|UTCUTC}
test clock-3.5 {clock format tests} {
list [catch {clock format} msg] $msg
} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean?"}}
test clock-3.6 {clock format tests} {
list [catch {clock format foo} msg] $msg
} {1 {expected integer but got "foo"}}
test clock-3.7 {clock format tests} {unixOrPc} {
|
| ︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
set oldenc [encoding system]
encoding system iso8859-1
set res [clock format 0 -format \u00c4]
encoding system $oldenc
unset oldenc
set res
} "\u00c4"
# clock scan
test clock-4.1 {clock scan tests} {
list [catch {clock scan} msg] $msg
} {1 {wrong # args: should be "clock scan dateString ?-base clockValue? ?-gmt boolean?"}}
test clock-4.2 {clock scan tests} {
list [catch {clock scan "bad-string"} msg] $msg
| > > > > > > > > > > > > > > > > > > > > > > | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
set oldenc [encoding system]
encoding system iso8859-1
set res [clock format 0 -format \u00c4]
encoding system $oldenc
unset oldenc
set res
} "\u00c4"
# Bug 942078
test clock-3.14 {change of time zone} -setup {
catch { unset oldTZ }
if { [info exists env(TZ)] } {
set oldTZ $env(TZ)
}
} -body {
set env(TZ) PST8PDT
set s [clock format 0 -format %H%M]
set env(TZ) GMT0
append s -[clock format 0 -format %H%M]
} -cleanup {
if { [info exists oldTZ] } {
set env(TZ) $oldTZ
unset oldTZ
} else {
unset env(TZ)
}
} -result {1600-0000}
# clock scan
test clock-4.1 {clock scan tests} {
list [catch {clock scan} msg] $msg
} {1 {wrong # args: should be "clock scan dateString ?-base clockValue? ?-gmt boolean?"}}
test clock-4.2 {clock scan tests} {
list [catch {clock scan "bad-string"} msg] $msg
|
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
clock format $time -format {%b %d, %Y %H:%M:%S}
} "Oct 23, 1992 00:00:00"
# CLOCK SCAN REAL TESTS
# We use 5am PST, 31-12-1999 as the base for these scans because irrespective
# of your local timezone it should always give us times on December 31, 1999
set 5amPST 946645200
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
clock format $time -format {%b %d, %Y %H:%M:%S}
} "Oct 23, 1992 00:00:00"
# CLOCK SCAN REAL TESTS
# We use 5am PST, 31-12-1999 as the base for these scans because irrespective
# of your local timezone it should always give us times on December 31, 1999
set 5amPST 946645200
test clock-4.19 {clock scan, number meridian} {
set t1 [clock scan "5 am" -base $5amPST -gmt true]
set t2 [clock scan "5 pm" -base $5amPST -gmt true]
set t3 [clock scan "5 a.m." -base $5amPST -gmt true]
set t4 [clock scan "5 p.m." -base $5amPST -gmt true]
list \
[clock format $t1 -format {%b %d, %Y %H:%M:%S} -gmt true] \
[clock format $t2 -format {%b %d, %Y %H:%M:%S} -gmt true] \
[clock format $t3 -format {%b %d, %Y %H:%M:%S} -gmt true] \
[clock format $t4 -format {%b %d, %Y %H:%M:%S} -gmt true]
} [list "Dec 31, 1999 05:00:00" "Dec 31, 1999 17:00:00" \
"Dec 31, 1999 05:00:00" "Dec 31, 1999 17:00:00"]
test clock-4.20 {clock scan, number:number meridian} {
clock format [clock scan "5:30 pm" -base $5amPST -gmt true] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Dec 31, 1999 17:30:00"
test clock-4.21 {clock scan, number:number-timezone} {
clock format [clock scan "00:00-0800" -gmt true -base $5amPST] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Dec 31, 1999 08:00:00"
test clock-4.22 {clock scan, number:number:number o_merid} {
clock format [clock scan "8:00:00" -gmt true -base $5amPST] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Dec 31, 1999 08:00:00"
test clock-4.23 {clock scan, number:number:number o_merid} {
clock format [clock scan "8:00:00 am" -gmt true -base $5amPST] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Dec 31, 1999 08:00:00"
test clock-4.24 {clock scan, number:number:number o_merid} {
clock format [clock scan "8:00:00 pm" -gmt true -base $5amPST] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Dec 31, 1999 20:00:00"
test clock-4.25 {clock scan, number:number:number-timezone} {
clock format [clock scan "00:00:30-0800" -gmt true -base $5amPST] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Dec 31, 1999 08:00:30"
test clock-4.26 {clock scan, DST for days} {
clock scan "tomorrow" -base [clock scan "19991031 00:00:00"]
} [clock scan "19991101 00:00:00"]
test clock-4.27 {clock scan, DST for days} {
clock scan "yesterday" -base [clock scan "19991101 00:00:00"]
} [clock scan "19991031 00:00:00"]
test clock-4.28 {clock scan, day} knownBug {
clock format [clock scan "Monday" -gmt true -base 946627200] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Jan 03, 2000 00:00:00"
test clock-4.29 {clock scan, number/number} {
clock format [clock scan "1/1" -gmt true -base 946627200] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Jan 01, 1999 00:00:00"
test clock-4.30 {clock scan, number/number} {
clock format [clock scan "1/1/1999" -gmt true -base 946627200] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Jan 01, 1999 00:00:00"
test clock-4.31 {clock scan, number/number} {
clock format [clock scan "19990101" -gmt true -base 946627200] \
-format {%b %d, %Y %H:%M:%S} -gmt true
} "Jan 01, 1999 00:00:00"
test clock-4.32 {clock scan, relative minutes} {
clock scan "now + 1 minute" -base 946627200
} 946627260
test clock-4.33 {clock scan, relative minutes} {
clock scan "now +1 minute" -base 946627200
} 946627260
test clock-4.34 {clock scan, relative minutes} {
clock scan "now 1 minute" -base 946627200
} 946627260
test clock-4.35 {clock scan, relative minutes} {
clock scan "now - 1 minute" -base 946627200
} 946627140
test clock-4.36 {clock scan, relative minutes} {
clock scan "now -1 minute" -base 946627200
} 946627140
test clock-4.37 {clock scan, day of week} {
clock format [clock scan "wednesday" -base [clock scan 20000112]] \
-format {%b %d, %Y}
} "Jan 12, 2000"
test clock-4.38 {clock scan, next day of week} {
clock format [clock scan "next wednesday" -base [clock scan 20000112]] \
-format {%b %d, %Y}
} "Jan 19, 2000"
test clock-4.39 {clock scan, day of week} {
clock format [clock scan "thursday" -base [clock scan 20000112]] \
-format {%b %d, %Y}
} "Jan 13, 2000"
test clock-4.40 {clock scan, next day of week} {
clock format [clock scan "next thursday" -base [clock scan 20000112]] \
-format {%b %d, %Y}
} "Jan 20, 2000"
# weekday specification and base.
test clock-4.41 {2nd monday in november} {
set res {}
foreach i {91 92 93 94 95 96} {
set nov8th [clock scan 11/8/$i]
set monday [clock scan monday -base $nov8th]
lappend res [clock format $monday -format %Y-%m-%d]
}
set res
} {1991-11-11 1992-11-09 1993-11-08 1994-11-14 1995-11-13 1996-11-11}
test clock-4.42 {2nd monday in november (2nd try)} {
set res {}
foreach i {91 92 93 94 95 96} {
set nov1th [clock scan 11/1/$i]
set monday [clock scan "2 monday" -base $nov1th]
lappend res [clock format $monday -format %Y-%m-%d]
}
set res
} {1991-11-11 1992-11-09 1993-11-08 1994-11-14 1995-11-13 1996-11-11}
test clock-4.43 {last monday in november} {
set res {}
foreach i {91 92 93 94 95 96} {
set dec1th [clock scan 12/1/$i]
set monday [clock scan "monday 1 week ago" -base $dec1th]
lappend res [clock format $monday -format %Y-%m-%d]
}
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
test clock-4.44 {2nd monday in november} knownBug {
set res {}
foreach i {91 92 93 94 95 96} {
set nov8th [clock scan 11/8/$i -gmt 1]
set monday [clock scan monday -base $nov8th -gmt 1]
lappend res [clock format $monday -format %Y-%m-%d -gmt 1]
}
set res
} {1991-11-11 1992-11-09 1993-11-08 1994-11-14 1995-11-13 1996-11-11}
test clock-4.45 {2nd monday in november (2nd try)} knownBug {
set res {}
foreach i {91 92 93 94 95 96} {
set nov1th [clock scan 11/1/$i -gmt 1]
set monday [clock scan "2 monday" -base $nov1th -gmt 1]
lappend res [clock format $monday -format %Y-%m-%d -gmt 1]
}
set res
} {1991-11-11 1992-11-09 1993-11-08 1994-11-14 1995-11-13 1996-11-11}
test clock-4.46 {last monday in november} knownBug {
set res {}
foreach i {91 92 93 94 95 96} {
set dec1th [clock scan 12/1/$i -gmt 1]
set monday [clock scan "monday 1 week ago" -base $dec1th -gmt 1]
lappend res [clock format $monday -format %Y-%m-%d -gmt 1]
}
set res
} {1991-11-25 1992-11-30 1993-11-29 1994-11-28 1995-11-27 1996-11-25}
test clock-4.47 {ago with multiple relative units} {
set base [clock scan "12/31/1999 00:00:00"]
set res [clock scan "2 days 2 hours ago" -base $base]
expr {$base - $res}
} 180000
# clock seconds
test clock-5.1 {clock seconds tests} {
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
set 5amPST 946645200
test clock-8.1 {clock scan midnight/gmt range bug 413397} {
set fmt "%m/%d"
list [clock format [clock scan year -base $5amPST -gmt 0] -format $fmt] \
[clock format [clock scan year -base $5amPST -gmt 1] -format $fmt]
} {12/31 12/31}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
set 5amPST 946645200
test clock-8.1 {clock scan midnight/gmt range bug 413397} {
set fmt "%m/%d"
list [clock format [clock scan year -base $5amPST -gmt 0] -format $fmt] \
[clock format [clock scan year -base $5amPST -gmt 1] -format $fmt]
} {12/31 12/31}
::tcltest::testConstraint needPST [expr {
[regexp {^(Pacific.*|P[DS]T)$} [clock format 1 -format %Z]]
&& ([clock format 1 -format %s] != "%s")
}]
test clock-9.1 {%s gmt testing} {needPST} {
# Note that this test will fail if the strftime on the underlying
# system doesn't support the %s format group. Systems that are known
# to have trouble include the native C libraries on AIX and HP-UX
# We need PST to guarantee the difference value below, and %s isn't
# valid on all OSes (like Solaris).
set s 100000
set a [clock format $s -format %s -gmt 0]
set b [clock format $s -format %s -gmt 1]
# This should be the offset in seconds between current locale and GMT.
# This didn't seem to be correctly on Windows until the fix for
# Bug #559376, which fiddled with env(TZ) when -gmt 1 was used.
# It's hard-coded to check P[SD]T now. (8 hours)
set c [expr {$b-$a}]
} {28800}
::tcltest::testConstraint percentG \
[expr { ![catch { clock format 0 -format %G -gmt true } y1970]
&& $y1970 eq {1970} }]
test clock-10.0 {Can strftime do %G?} {
clock format 0 -format %G -gmt true
} 1970
test clock-10.1 {ISO week-based calendar 2000-W52-1} {percentG} {
clock format 977702400 -format {%a %A %g %G %u %V %w} -gmt true; # 2000-12-25
} {Mon Monday 00 2000 1 52 1}
test clock-10.2 {ISO week-based calendar 2000-W52-7} {percentG} {
clock format 978220800 -format {%a %A %g %G %u %V %w} -gmt true; # 2000-12-31
} {Sun Sunday 00 2000 7 52 0}
test clock-10.3 {ISO week-based calendar 2001-W01-1} {percentG} {
clock format 978307200 -format {%a %A %g %G %u %V %w} -gmt true; # 2001-1-1
} {Mon Monday 01 2001 1 01 1}
test clock-10.4 {ISO week-based calendar 2001-W01-7} {percentG} {
clock format 978825600 -format {%a %A %g %G %u %V %w} -gmt true; # 2001-1-7
} {Sun Sunday 01 2001 7 01 0}
test clock-10.5 {ISO week-based calendar 2001-W02-1} {percentG} {
clock format 978912000 -format {%a %A %g %G %u %V %w} -gmt true; # 2001-1-8
} {Mon Monday 01 2001 1 02 1}
test clock-10.6 {ISO week-based calendar 2001-W52-1} {percentG} {
clock format 1009152000 -format {%a %A %g %G %u %V %w} -gmt true; # 2001-12-24
} {Mon Monday 01 2001 1 52 1}
test clock-10.7 {ISO week-based calendar 2001-W52-7} {percentG} {
clock format 1009670400 -format {%a %A %g %G %u %V %w} -gmt true; # 2001-12-30
} {Sun Sunday 01 2001 7 52 0}
test clock-10.8 {ISO week-based calendar 2002-W01-1} {percentG} {
clock format 1009756800 -format {%a %A %g %G %u %V %w} -gmt true; # 2001-12-31
} {Mon Monday 02 2002 1 01 1}
test clock-10.9 {ISO week-based calendar 2002-W01-2} {percentG} {
clock format 1009843200 -format {%a %A %g %G %u %V %w} -gmt true; # 2002-1-1
} {Tue Tuesday 02 2002 2 01 2}
test clock-10.10 {ISO week-based calendar 2002-W01-7} {percentG} {
clock format 1010275200 -format {%a %A %g %G %u %V %w} -gmt true; # 2002-1-6
} {Sun Sunday 02 2002 7 01 0}
test clock-10.11 {ISO week-based calendar 2002-W02-1} {percentG} {
clock format 1010361600 -format {%a %A %g %G %u %V %w} -gmt true; # 2002-1-7
} {Mon Monday 02 2002 1 02 1}
test clock-10.12 {ISO week-based calendar 2002-W52-1} {percentG} {
clock format 1040601600 -format {%a %A %g %G %u %V %w} -gmt true; # 2002-12-23
} {Mon Monday 02 2002 1 52 1}
test clock-10.13 {ISO week-based calendar 2002-W52-7} {percentG} {
clock format 1041120000 -format {%a %A %g %G %u %V %w} -gmt true; # 2002-12-29
} {Sun Sunday 02 2002 7 52 0}
test clock-10.14 {ISO week-based calendar 2003-W01-1} {percentG} {
clock format 1041206400 -format {%a %A %g %G %u %V %w} -gmt true; # 2002-12-30
} {Mon Monday 03 2003 1 01 1}
test clock-10.15 {ISO week-based calendar 2003-W01-2} {percentG} {
clock format 1041292800 -format {%a %A %g %G %u %V %w} -gmt true; # 2002-12-31
} {Tue Tuesday 03 2003 2 01 2}
test clock-10.16 {ISO week-based calendar 2003-W01-3} {percentG} {
clock format 1041379200 -format {%a %A %g %G %u %V %w} -gmt true; # 2003-1-1
} {Wed Wednesday 03 2003 3 01 3}
test clock-10.17 {ISO week-based calendar 2003-W01-7} {percentG} {
clock format 1041724800 -format {%a %A %g %G %u %V %w} -gmt true; # 2003-1-5
} {Sun Sunday 03 2003 7 01 0}
test clock-10.18 {ISO week-based calendar 2003-W02-1} {percentG} {
clock format 1041811200 -format {%a %A %g %G %u %V %w} -gmt true; # 2003-1-6
} {Mon Monday 03 2003 1 02 1}
test clock-10.19 {ISO week-based calendar 2003-W52-1} {percentG} {
clock format 1072051200 -format {%a %A %g %G %u %V %w} -gmt true; # 2003-12-22
} {Mon Monday 03 2003 1 52 1}
test clock-10.20 {ISO week-based calendar 2003-W52-7} {percentG} {
clock format 1072569600 -format {%a %A %g %G %u %V %w} -gmt true; # 2003-12-28
} {Sun Sunday 03 2003 7 52 0}
test clock-10.21 {ISO week-based calendar 2004-W01-1} {percentG} {
clock format 1072656000 -format {%a %A %g %G %u %V %w} -gmt true; # 2003-12-29
} {Mon Monday 04 2004 1 01 1}
test clock-10.22 {ISO week-based calendar 2004-W01-3} {percentG} {
clock format 1072828800 -format {%a %A %g %G %u %V %w} -gmt true; # 2003-12-31
} {Wed Wednesday 04 2004 3 01 3}
test clock-10.23 {ISO week-based calendar 2004-W01-4} {percentG} {
clock format 1072915200 -format {%a %A %g %G %u %V %w} -gmt true; # 2004-1-1
} {Thu Thursday 04 2004 4 01 4}
test clock-10.24 {ISO week-based calendar 2004-W01-7} {percentG} {
clock format 1073174400 -format {%a %A %g %G %u %V %w} -gmt true; # 2004-1-4
} {Sun Sunday 04 2004 7 01 0}
test clock-10.25 {ISO week-based calendar 2004-W02-1} {percentG} {
clock format 1073260800 -format {%a %A %g %G %u %V %w} -gmt true; # 2004-1-5
} {Mon Monday 04 2004 1 02 1}
test clock-10.26 {ISO week-based calendar 2004-W52-1} {percentG} {
clock format 1103500800 -format {%a %A %g %G %u %V %w} -gmt true; # 2004-12-20
} {Mon Monday 04 2004 1 52 1}
test clock-10.27 {ISO week-based calendar 2004-W52-7} {percentG} {
clock format 1104019200 -format {%a %A %g %G %u %V %w} -gmt true; # 2004-12-26
} {Sun Sunday 04 2004 7 52 0}
test clock-10.28 {ISO week-based calendar 2004-W53-1} {percentG} {
clock format 1104105600 -format {%a %A %g %G %u %V %w} -gmt true; # 2004-12-27
} {Mon Monday 04 2004 1 53 1}
test clock-10.29 {ISO week-based calendar 2004-W53-5} {percentG} {
clock format 1104451200 -format {%a %A %g %G %u %V %w} -gmt true; # 2004-12-31
} {Fri Friday 04 2004 5 53 5}
test clock-10.30 {ISO week-based calendar 2004-W53-6} {percentG} {
clock format 1104537600 -format {%a %A %g %G %u %V %w} -gmt true; # 2005-1-1
} {Sat Saturday 04 2004 6 53 6}
test clock-10.31 {ISO week-based calendar 2004-W53-7} {percentG} {
clock format 1104624000 -format {%a %A %g %G %u %V %w} -gmt true; # 2005-1-2
} {Sun Sunday 04 2004 7 53 0}
test clock-10.32 {ISO week-based calendar 2005-W01-1} {percentG} {
clock format 1104710400 -format {%a %A %g %G %u %V %w} -gmt true; # 2005-1-3
} {Mon Monday 05 2005 1 01 1}
test clock-10.33 {ISO week-based calendar 2005-W01-7} {percentG} {
clock format 1105228800 -format {%a %A %g %G %u %V %w} -gmt true; # 2005-1-9
} {Sun Sunday 05 2005 7 01 0}
test clock-10.34 {ISO week-based calendar 2005-W02-1} {percentG} {
clock format 1105315200 -format {%a %A %g %G %u %V %w} -gmt true; # 2005-1-10
} {Mon Monday 05 2005 1 02 1}
test clock-10.35 {ISO week-based calendar 2005-W52-1} {percentG} {
clock format 1135555200 -format {%a %A %g %G %u %V %w} -gmt true; # 2005-12-26
} {Mon Monday 05 2005 1 52 1}
test clock-10.36 {ISO week-based calendar 2005-W52-6} {percentG} {
clock format 1135987200 -format {%a %A %g %G %u %V %w} -gmt true; # 2005-12-31
} {Sat Saturday 05 2005 6 52 6}
test clock-10.37 {ISO week-based calendar 2005-W52-7} {percentG} {
clock format 1136073600 -format {%a %A %g %G %u %V %w} -gmt true; # 2006-1-1
} {Sun Sunday 05 2005 7 52 0}
test clock-10.38 {ISO week-based calendar 2006-W01-1} {percentG} {
clock format 1136160000 -format {%a %A %g %G %u %V %w} -gmt true; # 2006-1-2
} {Mon Monday 06 2006 1 01 1}
test clock-10.39 {ISO week-based calendar 2006-W01-7} {percentG} {
clock format 1136678400 -format {%a %A %g %G %u %V %w} -gmt true; # 2006-1-8
} {Sun Sunday 06 2006 7 01 0}
test clock-10.40 {ISO week-based calendar 2006-W02-1} {percentG} {
clock format 1136764800 -format {%a %A %g %G %u %V %w} -gmt true; # 2006-1-9
} {Mon Monday 06 2006 1 02 1}
test clock-10.41 {ISO week-based calendar 2009-W52-1} {percentG} {
clock format 1261353600 -format {%a %A %g %G %u %V %w} -gmt true; # 2009-12-21
} {Mon Monday 09 2009 1 52 1}
test clock-10.42 {ISO week-based calendar 2009-W52-7} {percentG} {
clock format 1261872000 -format {%a %A %g %G %u %V %w} -gmt true; # 2009-12-27
} {Sun Sunday 09 2009 7 52 0}
test clock-10.43 {ISO week-based calendar 2009-W53-1} {percentG} {
clock format 1261958400 -format {%a %A %g %G %u %V %w} -gmt true; # 2009-12-28
} {Mon Monday 09 2009 1 53 1}
test clock-10.44 {ISO week-based calendar 2009-W53-4} {percentG} {
clock format 1262217600 -format {%a %A %g %G %u %V %w} -gmt true; # 2009-12-31
} {Thu Thursday 09 2009 4 53 4}
test clock-10.45 {ISO week-based calendar 2009-W53-5} {percentG} {
clock format 1262304000 -format {%a %A %g %G %u %V %w} -gmt true; # 2010-1-1
} {Fri Friday 09 2009 5 53 5}
test clock-10.46 {ISO week-based calendar 2009-W53-7} {percentG} {
clock format 1262476800 -format {%a %A %g %G %u %V %w} -gmt true; # 2010-1-3
} {Sun Sunday 09 2009 7 53 0}
test clock-10.47 {ISO week-based calendar 2010-W01-1} {percentG} {
clock format 1262563200 -format {%a %A %g %G %u %V %w} -gmt true; # 2010-1-4
} {Mon Monday 10 2010 1 01 1}
test clock-10.48 {ISO week-based calendar 2010-W01-7} {percentG} {
clock format 1263081600 -format {%a %A %g %G %u %V %w} -gmt true; # 2010-1-10
} {Sun Sunday 10 2010 7 01 0}
test clock-10.49 {ISO week-based calendar 2010-W02-1} {percentG} {
clock format 1263168000 -format {%a %A %g %G %u %V %w} -gmt true; # 2010-1-11
} {Mon Monday 10 2010 1 02 1}
test clock-41.1 {regression test - format group %k when hour is 0 } {
clock format 0 -format %k -gmt true
} { 0}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/cmdAH.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # The file tests the tclCmdAH.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1998 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# The file tests the tclCmdAH.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1998 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdAH.test,v 1.30.2.6 2006/10/01 13:17:34 patthoyts Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]
|
| ︙ | ︙ | |||
82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
} 1
test cmdAH-2.5 {Tcl_CdObjCmd} {
list [catch {cd ~~} msg] $msg
} {1 {user "~" doesn't exist}}
test cmdAH-2.6 {Tcl_CdObjCmd} {
list [catch {cd _foobar} msg] $msg
} {1 {couldn't change working directory to "_foobar": no such file or directory}}
test cmdAH-2.7 {Tcl_ConcatObjCmd} {
concat
} {}
test cmdAH-2.8 {Tcl_ConcatObjCmd} {
concat a
} a
| > > > | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
} 1
test cmdAH-2.5 {Tcl_CdObjCmd} {
list [catch {cd ~~} msg] $msg
} {1 {user "~" doesn't exist}}
test cmdAH-2.6 {Tcl_CdObjCmd} {
list [catch {cd _foobar} msg] $msg
} {1 {couldn't change working directory to "_foobar": no such file or directory}}
test cmdAH-2.6.1 {Tcl_CdObjCmd} {
list [catch {cd ""} msg] $msg
} {1 {couldn't change working directory to "": no such file or directory}}
test cmdAH-2.7 {Tcl_ConcatObjCmd} {
concat
} {}
test cmdAH-2.8 {Tcl_ConcatObjCmd} {
concat a
} a
|
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
test cmdAH-5.4 {Tcl_FileObjCmd} {
list [catch {file exists ""} msg] $msg
} {0 0}
#volume
test cmdAH-6.1 {Tcl_FileObjCmd: volumes} {
| | | | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
test cmdAH-5.4 {Tcl_FileObjCmd} {
list [catch {file exists ""} msg] $msg
} {0 0}
#volume
test cmdAH-6.1 {Tcl_FileObjCmd: volumes} {
list [catch {file volumes x} msg] $msg
} {1 {wrong # args: should be "file volumes"}}
test cmdAH-6.2 {Tcl_FileObjCmd: volumes} {
set volumeList [file volumes]
if { [llength $volumeList] == 0 } {
set result 0
} else {
set result 1
}
} {1}
test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {macOrUnix} {
set volumeList [file volumes]
catch [list glob -nocomplain [lindex $volumeList 0]*]
} {0}
test cmdAH-6.4 {Tcl_FileObjCmd: volumes} winOnly {
set volumeList [string tolower [file volumes]]
list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}]
} {0 1 0}
test cmdAH-6.5 {cd} {unixOnly nonPortable} {
set dir [pwd]
cd /
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
test cmdAH-8.42 {Tcl_FileObjCmd: dirname} {
testsetplatform mac
list [catch {file dirname ~:baz} msg] $msg
} {0 ~:}
test cmdAH-8.43 {Tcl_FileObjCmd: dirname} {
global env
set temp $env(HOME)
| | | | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 |
test cmdAH-8.42 {Tcl_FileObjCmd: dirname} {
testsetplatform mac
list [catch {file dirname ~:baz} msg] $msg
} {0 ~:}
test cmdAH-8.43 {Tcl_FileObjCmd: dirname} {
global env
set temp $env(HOME)
set env(HOME) "/homewontexist/test"
testsetplatform unix
set result [list [catch {file dirname ~} msg] $msg]
set env(HOME) $temp
set result
} {0 /homewontexist}
test cmdAH-8.44 {Tcl_FileObjCmd: dirname} {
global env
set temp $env(HOME)
set env(HOME) "~"
testsetplatform unix
set result [list [catch {file dirname ~} msg] $msg]
set env(HOME) $temp
set result
} {0 ~}
test cmdAH-8.45 {Tcl_FileObjCmd: dirname} {
global env
set temp $env(HOME)
set env(HOME) "/homewontexist/test"
testsetplatform windows
set result [list [catch {file dirname ~} msg] $msg]
set env(HOME) $temp
set result
} {0 /homewontexist}
test cmdAH-8.46 {Tcl_FileObjCmd: dirname} {
global env
set temp $env(HOME)
set env(HOME) "/home/test"
testsetplatform mac
set result [list [catch {file dirname ~} msg] $msg]
set env(HOME) $temp
|
| ︙ | ︙ | |||
1057 1058 1059 1060 1061 1062 1063 |
removeDirectory $dirfile
set dirfile [makeDirectory dir.file]
set gorpfile [makeFile abcde gorp.file]
test cmdAH-18.1 {Tcl_FileObjCmd: executable} {testchmod} {
list [catch {file executable a b} msg] $msg
} {1 {wrong # args: should be "file executable name"}}
| | | | | | | | | 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 |
removeDirectory $dirfile
set dirfile [makeDirectory dir.file]
set gorpfile [makeFile abcde gorp.file]
test cmdAH-18.1 {Tcl_FileObjCmd: executable} {testchmod} {
list [catch {file executable a b} msg] $msg
} {1 {wrong # args: should be "file executable name"}}
test cmdAH-18.2 {Tcl_FileObjCmd: executable} {testchmod notRoot} {
file executable $gorpfile
} 0
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unixOnly testchmod} {
# Only on unix will setting the execute bit on a regular file
# cause that file to be executable.
testchmod 0775 $gorpfile
file exe $gorpfile
} 1
test cmdAH-18.4 {Tcl_FileObjCmd: executable} {macOnly testchmod} {
# On mac, the only executable files are of type APPL.
set x [file exe $gorpfile]
file attrib $gorpfile -type APPL
lappend x [file exe $gorpfile]
} {0 1}
test cmdAH-18.5 {Tcl_FileObjCmd: executable} {winOnly testchmod} {
# On pc, must be a .exe, .com, etc.
set x [file exe $gorpfile]
set gorpexe [makeFile foo gorp.exe]
lappend x [file exe $gorpexe]
removeFile $gorpexe
set x
} {0 1}
test cmdAH-18.6 {Tcl_FileObjCmd: executable} {testchmod} {
# Directories are always executable.
file exe $dirfile
} 1
removeDirectory $dirfile
removeFile $gorpfile
set linkfile [file join [temporaryDirectory] link.file]
file delete $linkfile
|
| ︙ | ︙ | |||
1295 1296 1297 1298 1299 1300 1301 |
file mkdir $dirA/b $dirB/a/c
set res [list [file isdirectory $dirA/b] [file isdirectory $dirB/a/c]]
file delete -force $dirA
file delete -force $dirB
set res
} {1 1}
| | > > > > > > > > > > > > > > > > > > > > < > | < > | | | > | 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 |
file mkdir $dirA/b $dirB/a/c
set res [list [file isdirectory $dirA/b] [file isdirectory $dirB/a/c]]
file delete -force $dirA
file delete -force $dirB
set res
} {1 1}
# mtime
proc waitForEvenSecondForFAT {} {
# Windows 9x uses filesystems (the FAT* family of FSes) without
# enough data in its timestamps for even per-second-accurate
# timings. :^(
# This procedure based on work by Helmut Giese
global tcl_platform
if {$tcl_platform(platform) ne "windows"} {return}
if {[lindex [file system [temporaryDirectory]] 1] == "NTFS"} {return}
# Assume non-NTFS means FAT{12,16,32} and hence in need of special help
set start [clock seconds]
while {1} {
set now [clock seconds]
if {$now!=$start && !($now & 1)} {
return
}
after 50
}
}
set file [makeFile "data" touch.me]
test cmdAH-24.1 {Tcl_FileObjCmd: mtime} {
list [catch {file mtime a b c} msg] $msg
} {1 {wrong # args: should be "file mtime name ?time?"}}
# Check (allowing for clock-skew and OS interrupts as best we can)
# that the change in mtime on a file being written is the time elapsed
# between writes. Note that this can still fail on very busy systems
# if there are long preemptions between the writes and the reading of
# the clock, but there's not much you can do about that other than the
# completely horrible "keep on trying to write until you managed to do
# it all in less than a second." - DKF
test cmdAH-24.2 {Tcl_FileObjCmd: mtime} {
waitForEvenSecondForFAT
set f [open $gorpfile w]
puts $f "More text"
close $f
set clockOld [clock seconds]
set fileOld [file mtime $gorpfile]
after 2000
set f [open $gorpfile w]
puts $f "More text"
close $f
set clockNew [clock seconds]
set fileNew [file mtime $gorpfile]
expr {
(($fileNew > $fileOld) && ($clockNew > $clockOld) &&
(abs(($fileNew-$fileOld) - ($clockNew-$clockOld)) <= 1)) ? "1" :
"file:($fileOld=>$fileNew) clock:($clockOld=>$clockNew)"
}
} {1}
test cmdAH-24.3 {Tcl_FileObjCmd: mtime} {
catch {unset stat}
file stat $gorpfile stat
list [expr {[file mtime $gorpfile] == $stat(mtime)}] \
[expr {[file atime $gorpfile] == $stat(atime)}]
|
| ︙ | ︙ | |||
1346 1347 1348 1349 1350 1351 1352 |
if {[string equal $tcl_platform(platform) "unix"]} {
set name /tmp/tcl.test.[pid]
} else {
set name [file join [temporaryDirectory] tf]
}
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 |
if {[string equal $tcl_platform(platform) "unix"]} {
set name /tmp/tcl.test.[pid]
} else {
set name [file join [temporaryDirectory] tf]
}
# Make sure that a new file's time is correct. 10 seconds variance
# is allowed used due to slow networks or clock skew on a network drive.
file delete -force $name
close [open $name w]
set a [expr abs([clock seconds]-[file mtime $name])<10]
file delete $name
set a
} {1}
test cmdAH-24.7 {Tcl_FileObjCmd: mtime} {
list [catch {file mtime $file notint} msg] $msg
} {1 {expected integer but got "notint"}}
test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} macOrUnix {
set mtime [file mtime $file]
after 1100; # pause a sec to notice change in mtime
set newmtime [clock seconds]
set modmtime [file mtime $file $newmtime]
expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
} 1
test cmdAH-24.9 {Tcl_FileObjCmd: mtime touch with non-ascii chars} macOrUnix {
set oldfile $file
# introduce some non-ascii characters.
append file \u2022
file delete -force $file
file rename $oldfile $file
set mtime [file mtime $file]
after 1100; # pause a sec to notice change in mtime
set newmtime [clock seconds]
set err [catch {file mtime $file $newmtime} modmtime]
file rename $file $oldfile
if {$err} {
error $modmtime
}
expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
} 1
test cmdAH-24.10 {Tcl_FileObjCmd: mtime touch} winOnly {
waitForEvenSecondForFAT
set mtime [file mtime $file]
after 2100; # pause two secs to notice change in mtime on FAT fs'es
set newmtime [clock seconds]
set modmtime [file mtime $file $newmtime]
expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
} 1
test cmdAH-24.11 {Tcl_FileObjCmd: mtime touch with non-ascii chars} winOnly {
waitForEvenSecondForFAT
set oldfile $file
# introduce some non-ascii characters.
append file \u2022
file delete -force $file
file rename $oldfile $file
set mtime [file mtime $file]
after 2100; # pause two secs to notice change in mtime on FAT fs'es
set newmtime [clock seconds]
set err [catch {file mtime $file $newmtime} modmtime]
file rename $file $oldfile
if {$err} {
error $modmtime
}
expr {$newmtime == $modmtime ? 1 : "$newmtime != $modmtime"}
} 1
removeFile touch.me
rename waitForEvenSecondForFAT {}
test cmdAH-24.12 {Tcl_FileObjCmd: mtime and daylight savings} {
set name [file join [temporaryDirectory] clockchange]
file delete -force $name
close [open $name w]
set time [clock scan "21:00:00 October 30 2004 GMT"]
file mtime $name $time
set newmtime [file mtime $name]
file delete $name
expr {$newmtime == $time ? 1 : "$newmtime != $time"}
} {1}
# bug 1420432: setting mtime fails for directories on windows.
test cmdAH-24.13 {Tcl_FileObjCmd: directory mtime} {
set dirname [file join [temporaryDirectory] tmp[pid]]
file delete -force $dirname
file mkdir $dirname
set res [catch {
set old [file mtime $dirname]
file mtime $dirname 0
set new [file mtime $dirname]
list $new [expr {$old != $new}]
} err]
file delete -force $dirname
list $res $err
} {0 {0 1}}
# owned
test cmdAH-25.1 {Tcl_FileObjCmd: owned} {
list [catch {file owned a b} msg] $msg
} {1 {wrong # args: should be "file owned name"}}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} {
|
| ︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 |
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} {
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
| | | 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 |
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-26.4 {Tcl_FileObjCmd: readlink errors} {macOnly nonPortable} {
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {could not readlink "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-26.5 {Tcl_FileObjCmd: readlink errors} {winOnly nonPortable} {
list [catch {file readlink _bogus_} msg] [string tolower $msg] \
[string tolower $errorCode]
} {1 {could not readlink "_bogus_": invalid argument} {posix einval {invalid argument}}}
# size
test cmdAH-27.1 {Tcl_FileObjCmd: size} {
|
| ︙ | ︙ | |||
1480 1481 1482 1483 1484 1485 1486 |
set filename [makeFile "" foo.text]
file stat $filename stat
set x [expr {$stat(mode) > 0}]
removeFile $filename
set x
} 1
| | | | | | | 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 |
set filename [makeFile "" foo.text]
file stat $filename stat
set x [expr {$stat(mode) > 0}]
removeFile $filename
set x
} 1
test cmdAH-28.9 {Tcl_FileObjCmd: stat} winOnly {
# stat of root directory was failing.
# don't care about answer, just that test runs.
# relative paths that resolve to root
set old [pwd]
cd c:/
file stat c: stat
file stat c:. stat
file stat . stat
cd $old
file stat / stat
file stat c:/ stat
file stat c:/. stat
} {}
test cmdAH-28.10 {Tcl_FileObjCmd: stat} {winOnly nonPortable} {
# stat of root directory was failing.
# don't care about answer, just that test runs.
file stat //pop/$env(USERNAME) stat
file stat //pop/$env(USERNAME)/ stat
file stat //pop/$env(USERNAME)/. stat
} {}
test cmdAH-28.11 {Tcl_FileObjCmd: stat} {winOnly nonPortable} {
# stat of network directory was returning id of current local drive.
set old [pwd]
cd c:/
file stat //pop/$env(USERNAME) stat
cd $old
|
| ︙ | ︙ |
Changes to tests/cmdIL.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclCmdIL.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file contains a collection of tests for the procedures in the
# file tclCmdIL.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdIL.test,v 1.14.6.2 2007/03/10 14:57:38 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} {
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
} [list 0 [list [list a b] [list c d]]]
# Note that the required order only exists in the end-1'th element;
# indexing using the end element or any fixed offset from the start
# will not work...
test cmdIL-1.26 {Tcl_LsortObjCmd procedure, offset indexing from end} {
lsort -index end-1 {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}}
} {{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}}
# Can't think of any good tests for the MergeSort and MergeLists
# procedures, except a bunch of random lists to sort.
test cmdIL-2.1 {MergeSort and MergeLists procedures} {
set result {}
set r 1435753299
| > > > > > | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
} [list 0 [list [list a b] [list c d]]]
# Note that the required order only exists in the end-1'th element;
# indexing using the end element or any fixed offset from the start
# will not work...
test cmdIL-1.26 {Tcl_LsortObjCmd procedure, offset indexing from end} {
lsort -index end-1 {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}}
} {{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}}
test cmdIL-1.29 {Tcl_LsortObjCmd procedure, loss of list rep during sorting} {
set l {1 2 3}
proc testcmp args {string length $::l}
string length [lsort -command testcmp $l]
} 5
# Can't think of any good tests for the MergeSort and MergeLists
# procedures, except a bunch of random lists to sort.
test cmdIL-2.1 {MergeSort and MergeLists procedures} {
set result {}
set r 1435753299
|
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
lsort -command {cmp {this argument is very very long in order to make the dstring overflow its statically allocated space}} {{this first element is also long in order to help expand the dstring} {the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring}}
} {{the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring} {this first element is also long in order to help expand the dstring}}
test cmdIL-3.17 {SortCompare procedure, -command option, non-integer result} {
proc cmp {a b} {
return foow
}
list [catch {lsort -command cmp {48 6}} msg] $msg
| | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
lsort -command {cmp {this argument is very very long in order to make the dstring overflow its statically allocated space}} {{this first element is also long in order to help expand the dstring} {the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring}}
} {{the second element, last but not least, is quite long also, in order to make absolutely sure that space is allocated dynamically for the dstring} {this first element is also long in order to help expand the dstring}}
test cmdIL-3.17 {SortCompare procedure, -command option, non-integer result} {
proc cmp {a b} {
return foow
}
list [catch {lsort -command cmp {48 6}} msg] $msg
} {1 {-compare command returned non-integer result}}
test cmdIL-3.18 {SortCompare procedure, -command option} {
proc cmp {a b} {
expr {$b - $a}
}
lsort -command cmp {48 6 18 22 21 35 36}
} {48 36 35 22 21 18 6}
test cmdIL-3.19 {SortCompare procedure, -decreasing option} {
|
| ︙ | ︙ |
Changes to tests/cmdMZ.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # The tests in this file cover the procedures in tclCmdMZ.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | < < | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
# The tests in this file cover the procedures in tclCmdMZ.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: cmdMZ.test,v 1.13.2.3 2004/02/25 23:38:16 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
# Tcl_PwdObjCmd
test cmdMZ-1.1 {Tcl_PwdObjCmd} {
list [catch {pwd a} msg] $msg
} {1 {wrong # args: should be "pwd"}}
test cmdMZ-1.2 {Tcl_PwdObjCmd: simple pwd} {
catch pwd
} 0
test cmdMZ-1.3 {Tcl_PwdObjCmd: simple pwd} {
expr [string length pwd]>0
} 1
test cmdMZ-1.4 {Tcl_PwdObjCmd: failure} {unixOnly nonPortable} {
# This test fails on various unix platforms (eg Linux) where
# permissions caching causes this to fail. The caching is strictly
# incorrect, but we have no control over that.
set foodir [file join [temporaryDirectory] foo]
file delete -force $foodir
file mkdir $foodir
set cwd [pwd]
cd $foodir
file attr . -permissions 000
set result [list [catch {pwd} msg] $msg]
|
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
list [catch {source} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
list [catch {source a b} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
| > > > > > > > > > > > > > > | > | > < | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
list [catch {source} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} {
list [catch {source a b} msg] $msg
} {1 {wrong # args: should be "source fileName"}}
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
return 0
}
foreach e $expected a $actual {
if {![string match $e $a]} {
return 0
}
}
return 1
}
customMatch listGlob ListGlobMatch
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -setup {
set file [makeFile {
set x 146
error "error in sourced file"
set y $x
} source.file]
} -body {
list [catch {source $file} msg] $msg $errorInfo
} -cleanup {
removeFile source.file
} -match listGlob -result {1 {error in sourced file} {error in sourced file
while executing
"error "error in sourced file""
(file "*" line 3)
invoked from within
"source $file"}}
test cmdMZ-3.6 {Tcl_SourceObjCmd: simple script} {
set file [makeFile {list result} source.file]
|
| ︙ | ︙ |
Changes to tests/compile.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # This file contains tests for the files tclCompile.c, tclCompCmds.c # and tclLiteral.c # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # This file contains tests for the files tclCompile.c, tclCompCmds.c # and tclLiteral.c # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: compile.test,v 1.24.2.3 2004/10/26 20:14:36 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* # The following tests are very incomplete, although the rest of the # test suite covers this file fairly well. |
| ︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
set fail [catch {
return 1
}] ; # {}
return 2
}
foo
} {2}
test compile-4.1 {TclCompileForCmd: command substituted test expression} {
set i 0
set j 0
# Should be "forever"
for {} [expr $i < 3] {} {
set j [incr i]
| > > > > > > > > > > > | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
set fail [catch {
return 1
}] ; # {}
return 2
}
foo
} {2}
test compile-3.5 {TclCompileCatchCmd: recover from error, [Bug 705406]} {
proc foo {} {
catch {
if {[a]} {
if b {}
}
}
}
list [catch foo msg] $msg
} {0 1}
test compile-4.1 {TclCompileForCmd: command substituted test expression} {
set i 0
set j 0
# Should be "forever"
for {} [expr $i < 3] {} {
set j [incr i]
|
| ︙ | ︙ | |||
305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
# Test to catch buffer overrun in TclCompileTokens from buf 530320
test compile-12.3 {check for a buffer overrun} {
proc crash {} {
puts $array([expr {a+2}])
}
list [catch crash msg] $msg
} {1 {syntax error in expression "a+2": variable references require preceding $}}
# Special test for underestimating the maxStackSize required for a
# compiled command. A failure will cause a segfault in the child
# process.
test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
set body {set x [list}
for {set i 0} {$i < 3000} {incr i} {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
# Test to catch buffer overrun in TclCompileTokens from buf 530320
test compile-12.3 {check for a buffer overrun} {
proc crash {} {
puts $array([expr {a+2}])
}
list [catch crash msg] $msg
} {1 {syntax error in expression "a+2": variable references require preceding $}}
test compile-12.4 {TclCleanupLiteralTable segfault} {
# Tcl Bug 1001997
# Here, we're trying to test a case that causes a crash in
# TclCleanupLiteralTable. The conditions that we're trying to
# establish are:
# - TclCleanupLiteralTable is attempting to clean up a bytecode
# object in the literal table.
# - The bytecode object in question contains the only reference
# to another literal.
# - The literal in question is in the same hash bucket as the bytecode
# object, and immediately follows it in the chain.
# Since newly registered literals are added at the FRONT of the
# bucket chains, and since the bytecode object is registered before
# its literals, this is difficult to achieve. What we do is:
# (a) do a [namespace eval] of a string that's calculated to
# hash into the same bucket as a literal that it contains.
# In this case, the script and the variable 'bugbug'
# land in the same bucket.
# (b) do a [namespace eval] of a string that contains enough
# literals to force TclRegisterLiteral to rebuild the global
# literal table. The newly created hash buckets will contain
# the literals, IN REVERSE ORDER, thus putting the bytecode
# immediately ahead of 'bugbug' and 'bug4345bug'. The bytecode
# object will contain the only references to those two literals.
# (c) Delete the interpreter to invoke TclCleanupLiteralTable
# and tickle the bug.
proc foo {} {
set i [interp create]
$i eval {
namespace eval ::w {concat 4649; variable bugbug}
namespace eval ::w {
concat x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 \
x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 \
x21 x22 x23 x24 x25 x26 x27 x28 x29 x30 \
x31 x32 X33 X34 X35 X36 X37 X38 X39 X40 \
x41 x42 x43 x44 x45 x46 x47 x48 x49 x50 \
x51 x52 x53 x54 x55 x56 x57 x58 x59 x60 \
x61 x62 x63 x64
concat y1 y2 y3 y4 y5 y6 y7 y8 y9 y10 \
y11 y12 y13 y14 y15 y16 y17 y18 y19 y20 \
y21 y22 y23 y24 y25 y26 y27 y28 y29 y30 \
y31 y32 Y33 Y34 Y35 Y36 Y37 Y38 Y39 Y40 \
y41 y42 y43 y44 y45 y46 y47 y48 y49 y50 \
y51 y52 y53 y54 y55 y56 y57 y58 y59 y60 \
y61 y62 y63 y64
concat z1 z2 z3 z4 z5 z6 z7 z8 z9 z10 \
z11 z12 z13 z14 z15 z16 z17 z18 z19 z20 \
z21 z22 z23 z24 z25 z26 z27 z28 z29 z30 \
z31 z32
}
}
interp delete $i; # must not crash
return ok
}
foo
} ok
# Special test for underestimating the maxStackSize required for a
# compiled command. A failure will cause a segfault in the child
# process.
test compile-13.1 {testing underestimate of maxStackSize in list cmd} {exec} {
set body {set x [list}
for {set i 0} {$i < 3000} {incr i} {
|
| ︙ | ︙ |
Changes to tests/encoding.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for tclEncoding.c # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file contains a collection of tests for tclEncoding.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: encoding.test,v 1.16.2.3 2006/10/05 21:24:56 hobbs Exp $
package require tcltest 2
namespace import -force ::tcltest::*
proc toutf {args} {
global x
lappend x "toutf $args"
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 293 294 |
test encoding-14.1 {BinaryProc} {
encoding convertto identity \x12\x34\x56\xff\x69
} "\x12\x34\x56\xc3\xbf\x69"
test encoding-15.1 {UtfToUtfProc} {
encoding convertto utf-8 \xa3
} "\xc2\xa3"
test encoding-16.1 {UnicodeToUtfProc} {
| > > > > > > > > > > > > > > > | > | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 |
test encoding-14.1 {BinaryProc} {
encoding convertto identity \x12\x34\x56\xff\x69
} "\x12\x34\x56\xc3\xbf\x69"
test encoding-15.1 {UtfToUtfProc} {
encoding convertto utf-8 \xa3
} "\xc2\xa3"
test encoding-15.2 {UtfToUtfProc null character output} {
set x \u0000
set y [encoding convertto utf-8 \u0000]
set y [encoding convertfrom identity $y]
binary scan $y H* z
list [string bytelength $x] [string bytelength $y] $z
} {2 1 00}
test encoding-15.3 {UtfToUtfProc null character input} {
set x [encoding convertfrom identity \x00]
set y [encoding convertfrom utf-8 $x]
binary scan [encoding convertto identity $y] H* z
list [string bytelength $x] [string bytelength $y] $z
} {1 2 c080}
test encoding-16.1 {UnicodeToUtfProc} {
set val [encoding convertfrom unicode NN]
list $val [format %x [scan $val %c]]
} "\u4e4e 4e4e"
test encoding-17.1 {UtfToUnicodeProc} {
} {}
test encoding-18.1 {TableToUtfProc} {
} {}
|
| ︙ | ︙ | |||
328 329 330 331 332 333 334 | cd [temporaryDirectory] set fid [open iso2022.txt w] fconfigure $fid -encoding binary puts -nonewline $fid $::iso2022encData close $fid | | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
cd [temporaryDirectory]
set fid [open iso2022.txt w]
fconfigure $fid -encoding binary
puts -nonewline $fid $::iso2022encData
close $fid
test encoding-23.1 {iso2022-jp escape encoding test} {
string equal $::iso2022uniData $::iso2022uniData2
} 1
test encoding-23.2 {iso2022-jp escape encoding test} {
# This checks that 'gets' isn't resetting the encoding inappropriately.
# [Bug #523988]
set fid [open iso2022.txt r]
fconfigure $fid -encoding iso2022-jp
|
| ︙ | ︙ |
Changes to tests/env.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: none (tests environment variable implementation) # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # Commands covered: none (tests environment variable implementation) # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: env.test,v 1.17.2.5 2007/01/19 01:05:50 das Exp $ package require tcltest 2 namespace import -force ::tcltest::* # # These tests will run on any platform (and indeed crashed # on the Mac). So put them before you test for the existance |
| ︙ | ︙ | |||
71 72 73 74 75 76 77 |
set names [lsort [array names env]]
if {$tcl_platform(platform) == "windows"} {
lrem names HOME
lrem names COMSPEC
lrem names ComSpec
lrem names ""
}
| > | > > > > | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
set names [lsort [array names env]]
if {$tcl_platform(platform) == "windows"} {
lrem names HOME
lrem names COMSPEC
lrem names ComSpec
lrem names ""
}
foreach name {
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
__CF_USER_TEXT_ENCODING SECURITYSESSIONID
} {
lrem names $name
}
foreach p $names {
puts "$p=$env($p)"
}
exit
} printenv]
|
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
}
return $out
}
# Save the current environment variables at the start of the test.
foreach name [array names env] {
| | > | > > > | | | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
}
return $out
}
# Save the current environment variables at the start of the test.
foreach name [array names env] {
set env2([string toupper $name]) $env($name)
unset env($name)
}
# Added the following lines so that child tcltest can actually find its
# library if the initial tcltest is run from a non-standard place.
# ('saved' env vars)
foreach name {
TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH
SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING
SECURITYSESSIONID} {
if {[info exists env2($name)]} {
set env($name) $env2($name);
}
}
test env-2.1 {adding environment variables} {exec} {
getenv
} {}
set env(NAME1) "test string"
|
| ︙ | ︙ | |||
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 |
set result
} {1 a 1}
test env-5.5 {corner cases - cannot have null entries on Windows} {pcOnly} {
set env() a
catch {set env()}
} {1}
# Restore the environment variables at the end of the test.
foreach name [array names env] {
unset env($name)
}
foreach name [array names env2] {
set env($name) $env2($name)
}
# cleanup
removeFile $printenvScript
::tcltest::cleanupTests
return
| > > > > > > > < < < < < < < < < < < < | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 |
set result
} {1 a 1}
test env-5.5 {corner cases - cannot have null entries on Windows} {pcOnly} {
set env() a
catch {set env()}
} {1}
test env-6.1 {corner cases - add lots of env variables} {} {
set size [array size env]
for {set i 0} {$i < 100} {incr i} {
set env(BOGUS$i) $i
}
expr {[array size env] - $size}
} 100
# Restore the environment variables at the end of the test.
foreach name [array names env] {
unset env($name)
}
foreach name [array names env2] {
set env($name) $env2($name)
}
# cleanup
removeFile $printenvScript
::tcltest::cleanupTests
return
|
Changes to tests/error.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: error, catch # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Commands covered: error, catch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: error.test,v 1.9.2.3 2006/01/11 17:29:46 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
proc foo {} {
global errorInfo
set a [catch {format [error glorp2]} b]
error {Human-generated}
|
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
# Make sure that catch resets error information
test error-6.1 {catch must reset error state} {
catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
list $errorCode $errorInfo
} {NONE 1}
| > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
# Make sure that catch resets error information
test error-6.1 {catch must reset error state} {
catch {error outer [catch {error inner inner.errorInfo inner.errorCode}]}
list $errorCode $errorInfo
} {NONE 1}
test error-6.3 {catch must reset error state} {
set errorCode BUG
catch {error outer [catch set]}
list $errorCode $errorInfo
} {NONE 1}
test error-6.4 {catch must reset error state} {
catch {error [catch {error foo bar baz}] 1}
list $errorCode $errorInfo
} {NONE 1}
test error-6.7 {catch must reset error state} {
proc foo {} {
return -code error -errorinfo [catch {error foo bar baz}]
}
catch foo
list $errorCode
} {NONE}
test error-6.9 {catch must reset error state} {
proc foo {} {
return -code error [catch {error foo bar baz}]
}
catch foo
list $errorCode
} {NONE}
namespace eval ::tcl::test::error {
test error-7.0 {Bug 1397843} -body {
variable cmds
proc EIWrite args {
variable cmds
lappend cmds [lindex [info level -2] 0]
}
proc BadProc {} {
set i a
incr i
}
trace add variable ::errorInfo write [namespace code EIWrite]
catch BadProc
trace remove variable ::errorInfo write [namespace code EIWrite]
set cmds
} -match glob -result {*BadProc*}
}
namespace delete ::tcl::test::error
# cleanup
catch {rename p ""}
::tcltest::cleanupTests
return
|
Changes to tests/event.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file contains a collection of tests for the procedures in the file # tclEvent.c, which includes the "update", and "vwait" Tcl # commands. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # # Copyright (c) 1995-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # This file contains a collection of tests for the procedures in the file # tclEvent.c, which includes the "update", and "vwait" Tcl # commands. Sourcing this file into Tcl runs the tests and generates # output for errors. No output means no errors were found. # # Copyright (c) 1995-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: event.test,v 1.20.2.1 2006/11/28 16:29:47 kennykb Exp $ package require tcltest 2 namespace import -force ::tcltest::* testConstraint testfilehandler [llength [info commands testfilehandler]] testConstraint testexithandler [llength [info commands testexithandler]] testConstraint testfilewait [llength [info commands testfilewait]] |
| ︙ | ︙ | |||
582 583 584 585 586 587 588 589 590 591 592 593 594 |
set result ""
lappend result [testfilewait $f readable 100]
lappend result [testfilewait $f readable -1]
close $f
set result
} {{} readable}
# cleanup
foreach i [after info] {
after cancel $i
}
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 |
set result ""
lappend result [testfilewait $f readable 100]
lappend result [testfilewait $f readable -1]
close $f
set result
} {{} readable}
test event-14.1 {Tcl_WaitForFile procedure, readable, big fd} \
-constraints {testfilehandler unix} \
-setup {
set chanList {}
for {set i 0} {$i < 32} {incr i} {
lappend chanList [open /dev/null r]
}
} \
-body {
foreach i [after info] {
after cancel $i
}
after 100 set x timeout
testfilehandler close
testfilehandler create 1 off off
set x "no timeout"
set result [testfilehandler wait 1 readable 0]
update
testfilehandler close
list $result $x
} \
-result {{} {no timeout}} \
-cleanup {
foreach chan $chanList {close $chan}
}
test event-14.2 {Tcl_WaitForFile procedure, readable, big fd} \
-constraints {testfilehandler unix} \
-setup {
set chanList {}
for {set i 0} {$i < 32} {incr i} {
lappend chanList [open /dev/null r]
}
} \
-body {
foreach i [after info] {
after cancel $i
}
after 100 set x timeout
testfilehandler close
testfilehandler create 1 off off
set x "no timeout"
set result [testfilehandler wait 1 readable 100]
update
testfilehandler close
list $result $x
} \
-result {{} timeout} \
-cleanup {
foreach chan $chanList {close $chan}
}
test event-14.3 {Tcl_WaitForFile procedure, readable, big fd} \
-constraints {testfilehandler unix} \
-setup {
set chanList {}
for {set i 0} {$i < 32} {incr i} {
lappend chanList [open /dev/null r]
}
} \
-body {
foreach i [after info] {
after cancel $i
}
after 100 set x timeout
testfilehandler close
testfilehandler create 1 off off
testfilehandler fillpartial 1
set x "no timeout"
set result [testfilehandler wait 1 readable 100]
update
testfilehandler close
list $result $x
} \
-result {readable {no timeout}} \
-cleanup {
foreach chan $chanList {close $chan}
}
test event-14.4 {Tcl_WaitForFile procedure, writable, big fd} \
-constraints {testfilehandler unix nonPortable} \
-setup {
set chanList {}
for {set i 0} {$i < 32} {incr i} {
lappend chanList [open /dev/null r]
}
} \
-body {
foreach i [after info] {
after cancel $i
}
after 100 set x timeout
testfilehandler close
testfilehandler create 1 off off
testfilehandler fill 1
set x "no timeout"
set result [testfilehandler wait 1 writable 0]
update
testfilehandler close
list $result $
} \
-result {{} {no timeout}} \
-cleanup {
foreach chan $chanList {close $chan}
}
test event-14.5 {Tcl_WaitForFile procedure, writable, big fd} \
-constraints {testfilehandler unix nonPortable} \
-setup {
set chanList {}
for {set i 0} {$i < 32} {incr i} {
lappend chanList [open /dev/null r]
}
} \
-body {
foreach i [after info] {
after cancel $i
}
after 100 set x timeout
testfilehandler close
testfilehandler create 1 off off
testfilehandler fill 1
set x "no timeout"
set result [testfilehandler wait 1 writable 100]
update
testfilehandler close
list $result $x
} \
-result {{} timeout} \
-cleanup {
foreach chan $chanList {close $chan}
}
test event-14.6 {Tcl_WaitForFile procedure, writable, big fd} \
-constraints {testfilehandler unix} \
-setup {
set chanList {}
for {set i 0} {$i < 32} {incr i} {
lappend chanList [open /dev/null r]
}
} \
-body {
foreach i [after info] {
after cancel $i
}
after 100 set x timeout
testfilehandler close
testfilehandler create 1 off off
set x "no timeout"
set result [testfilehandler wait 1 writable 100]
update
testfilehandler close
list $result $x
} \
-result {writable {no timeout}} \
-cleanup {
foreach chan $chanList {close $chan}
}
test event-14.7 {Tcl_WaitForFile, don't call other event handlers, big fd} \
-constraints {testfilehandler unix} \
-setup {
set chanList {}
for {set i 0} {$i < 32} {incr i} {
lappend chanList [open /dev/null r]
}
} \
-body {
foreach i [after info] {
after cancel $i
}
after 100 lappend x timeout
after idle lappend x idle
testfilehandler close
testfilehandler create 1 off off
set x ""
set result [list [testfilehandler wait 1 readable 200] $x]
update
testfilehandler close
lappend result $x
} \
-result {{} {} {timeout idle}} \
-cleanup {
foreach chan $chanList {close $chan}
}
test event-14.8 {Tcl_WaitForFile procedure, waiting indefinitely, big fd} \
-constraints {testfilewait unix} \
-body {
set f [open "|sleep 2" r]
set result ""
lappend result [testfilewait $f readable 100]
lappend result [testfilewait $f readable -1]
close $f
set result
} \
-setup {
set chanList {}
for {set i 0} {$i < 32} {incr i} {
lappend chanList [open /dev/null r]
}
} \
-result {{} readable} \
-cleanup {
foreach chan $chanList {close $chan}
}
# cleanup
foreach i [after info] {
after cancel $i
}
::tcltest::cleanupTests
return
|
Changes to tests/exec.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: exec # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# Commands covered: exec
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: exec.test,v 1.16.2.7 2006/01/16 19:31:19 rmax Exp $
package require tcltest 2
namespace import -force ::tcltest::*
# All tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]
unset -nocomplain path
set path(echo) [makeFile {
puts -nonewline [lindex $argv 0]
foreach str [lrange $argv 1 end] {
puts -nonewline " $str"
}
puts {}
exit
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
# occur before writing out the temp file.
exec [interpreter] $path(cat) << "\uE9\uE0\uFC\uF1"
} "\uE9\uE0\uFC\uF1"
# I/O redirection: output to file.
set path(gorp.file) [makeFile {} gorp.file]
| | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
# occur before writing out the temp file.
exec [interpreter] $path(cat) << "\uE9\uE0\uFC\uF1"
} "\uE9\uE0\uFC\uF1"
# I/O redirection: output to file.
set path(gorp.file) [makeFile {} gorp.file]
file delete $path(gorp.file)
test exec-3.1 {redirecting output to file} {exec} {
exec [interpreter] $path(echo) "Some simple words" > $path(gorp.file)
exec [interpreter] $path(cat) $path(gorp.file)
} "Some simple words"
test exec-3.2 {redirecting output to file} {exec stdio} {
exec [interpreter] $path(echo) "More simple words" | >$path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat)
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
puts $f "Line 3"
close $f
exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nMore text\nEven more\nLine 3"
# I/O redirection: output and stderr to file.
| | | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
puts $f "Line 3"
close $f
exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nMore text\nEven more\nLine 3"
# I/O redirection: output and stderr to file.
file delete $path(gorp.file)
test exec-4.1 {redirecting output and stderr to file} {exec} {
exec [interpreter] "$path(echo)" "test output" >& $path(gorp.file)
exec [interpreter] "$path(cat)" "$path(gorp.file)"
} "test output"
test exec-4.2 {redirecting output and stderr to file} {exec} {
list [exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" >&$path(gorp.file)] \
|
| ︙ | ︙ | |||
260 261 262 263 264 265 266 |
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" \
|& [interpreter] "$path(sh)" -c "\"$path(echo)\" second msg 1>&2 ; \"$path(cat)\"" |& [interpreter] "$path(cat)"
} "second msg\nfoo bar"
# I/O redirection: combinations.
set path(gorp.file2) [makeFile {} gorp.file2]
| | | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" \
|& [interpreter] "$path(sh)" -c "\"$path(echo)\" second msg 1>&2 ; \"$path(cat)\"" |& [interpreter] "$path(cat)"
} "second msg\nfoo bar"
# I/O redirection: combinations.
set path(gorp.file2) [makeFile {} gorp.file2]
file delete $path(gorp.file2)
test exec-7.1 {multiple I/O redirections} {exec} {
exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file)
exec [interpreter] $path(cat) $path(gorp.file2)
} {Just a few thoughts}
test exec-7.2 {multiple I/O redirections} {exec} {
exec < $path(gorp.file) << "command input" [interpreter] $path(cat)
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
close $f
test exec-10.20 {errors in exec invocation} {exec} {
list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
test exec-10.21 {errors in exec invocation} {exec} {
list [catch {exec [interpreter] true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}
| | > > > > | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
close $f
test exec-10.20 {errors in exec invocation} {exec} {
list [catch {exec ~non_existent_user/foo/bar} msg] $msg
} {1 {user "non_existent_user" doesn't exist}}
test exec-10.21 {errors in exec invocation} {exec} {
list [catch {exec [interpreter] true | ~xyzzy_bad_user/x | false} msg] $msg
} {1 {user "xyzzy_bad_user" doesn't exist}}
test exec-10.22 {errors in exec invocation} \
-constraints exec \
-returnCodes 1 \
-body {exec echo test > ~non_existent_user/foo/bar} \
-result {user "non_existent_user" doesn't exist}
# Commands in background.
test exec-11.1 {commands in background} {exec} {
set x [lindex [time {exec [interpreter] $path(sleep) 2 &}] 0]
expr $x<1000000
} 1
test exec-11.2 {commands in background} {exec} {
list [catch {exec [interpreter] $path(echo) a &b} msg] $msg
} {0 {a &b}}
test exec-11.3 {commands in background} {exec} {
llength [exec [interpreter] $path(sleep) 1 &]
} 1
test exec-11.4 {commands in background} {exec stdio} {
llength [exec [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 | [interpreter] $path(sleep) 1 &]
} 3
test exec-11.5 {commands in background} {exec} {
set f [open $path(gorp.file) w]
puts $f [list catch [list exec [info nameofexecutable] $path(echo) foo &]]
close $f
string compare "foo" [exec [interpreter] $path(gorp.file)]
} 0
# Make sure that background commands are properly reaped when
# they eventually die.
|
| ︙ | ︙ | |||
480 481 482 483 484 485 486 487 488 489 490 491 492 493 |
list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {exec} {
set x [catch {exec _weird_cmd_} msg]
list $x [string tolower $msg] [lindex $errorCode 0] \
[string tolower [lrange $errorCode 2 end]]
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}
# Switches before the first argument
test exec-14.1 {-keepnewline switch} {exec} {
exec -keepnewline [interpreter] $path(echo) foo
} "foo\n"
test exec-14.2 {-keepnewline switch} {exec} {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
list [catch {exec [interpreter] $path(cat) > a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.3 {setting errorCode variable} {exec} {
set x [catch {exec _weird_cmd_} msg]
list $x [string tolower $msg] [lindex $errorCode 0] \
[string tolower [lrange $errorCode 2 end]]
} {1 {couldn't execute "_weird_cmd_": no such file or directory} POSIX {{no such file or directory}}}
test exec-13.4 {extended exit result codes} {
-constraints {win}
-setup {
set tmp [makeFile {exit 0x00000101} tmpfile.exec-13.4]
}
-body {
list [catch {exec [interpreter] $tmp} err]\
[lreplace $::errorCode 1 1 {}]
}
-cleanup {
removeFile $tmp
}
-result {1 {CHILDSTATUS {} 257}}
}
test exec-13.5 {extended exit result codes: max value} {
-constraints {win}
-setup {
set tmp [makeFile {exit 0x3fffffff} tmpfile.exec-13.5]
}
-body {
list [catch {exec [interpreter] $tmp} err]\
[lreplace $::errorCode 1 1 {}]
}
-cleanup {
removeFile $tmp
}
-result {1 {CHILDSTATUS {} 1073741823}}
}
test exec-13.6 {extended exit result codes: signalled} {
-constraints {win}
-setup {
set tmp [makeFile {exit 0xffffffff} tmpfile.exec-13.6]
}
-body {
list [catch {exec [interpreter] $tmp} err]\
[lreplace $::errorCode 1 1 {}]
}
-cleanup {
removeFile $tmp
}
-result {1 {CHILDKILLED {} SIGABRT SIGABRT}}
}
# Switches before the first argument
test exec-14.1 {-keepnewline switch} {exec} {
exec -keepnewline [interpreter] $path(echo) foo
} "foo\n"
test exec-14.2 {-keepnewline switch} {exec} {
|
| ︙ | ︙ | |||
537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
} {First line
foo bar}
test exec-15.6 {standard error redirection} {exec stdio} {
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" > "$path(gorp.file2)" 2> "$path(gorp.file)" \
>& "$path(gorp.file)" 2> "$path(gorp.file2)" | [interpreter] "$path(echo)" biz baz
list [exec [interpreter] "$path(cat)" "$path(gorp.file)"] [exec [interpreter] "$path(cat)" "$path(gorp.file2)"]
} {{biz baz} {foo bar}}
test exec-16.1 {flush output before exec} {exec} {
set f [open $path(gorp.file) w]
puts $f "First line"
exec [interpreter] $path(echo) "Second line" >@ $f
puts $f "Third line"
close $f
| > > > > | 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 |
} {First line
foo bar}
test exec-15.6 {standard error redirection} {exec stdio} {
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" > "$path(gorp.file2)" 2> "$path(gorp.file)" \
>& "$path(gorp.file)" 2> "$path(gorp.file2)" | [interpreter] "$path(echo)" biz baz
list [exec [interpreter] "$path(cat)" "$path(gorp.file)"] [exec [interpreter] "$path(cat)" "$path(gorp.file2)"]
} {{biz baz} {foo bar}}
test exec-15.7 {standard error redirection 2>@1} {exec stdio} {
# This redirects stderr output into normal result output from exec
exec [interpreter] "$path(sh)" -c "\"$path(echo)\" foo bar 1>&2" 2>@1
} {foo bar}
test exec-16.1 {flush output before exec} {exec} {
set f [open $path(gorp.file) w]
puts $f "First line"
exec [interpreter] $path(echo) "Second line" >@ $f
puts $f "Third line"
close $f
|
| ︙ | ︙ | |||
563 564 565 566 567 568 569 |
Second line
Third line}
set path(script) [makeFile {} script]
test exec-17.1 { inheriting standard I/O } {exec} {
set f [open $path(script) w]
| | | > > | | | < | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
Second line
Third line}
set path(script) [makeFile {} script]
test exec-17.1 { inheriting standard I/O } {exec} {
set f [open $path(script) w]
puts -nonewline $f {close stdout
set f [}
puts $f [list open $path(gorp.file) w]]
puts $f [list catch \
[list exec [info nameofexecutable] $path(echo) foobar &]]
puts $f [list exec [info nameofexecutable] $path(sleep) 2]
puts $f {close $f}
close $f
catch {exec [interpreter] $path(script)} result
set f [open $path(gorp.file) r]
lappend result [read $f]
close $f
set result
} {{foobar
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 |
set fout [open $path(fooblah) w]
puts $fout "contents"
close $fout
set res [list [catch {exec cat $path(fooblah)} msg] $msg]
removeFile $f
set res
} {0 contents}
# cleanup
foreach file {script gorp.file gorp.file2 echo cat wc sh sleep exit err} {
removeFile $file
}
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 |
set fout [open $path(fooblah) w]
puts $fout "contents"
close $fout
set res [list [catch {exec cat $path(fooblah)} msg] $msg]
removeFile $f
set res
} {0 contents}
# Note that this test cannot be adapted to work on Windows; that platform has
# no kernel support for an analog of O_APPEND.
test exec-19.1 {exec >> uses O_APPEND} {
-constraints {exec unix}
-setup {
set tmpfile [makeFile {0} tmpfile.exec-19.1]
}
-body {
# Note that we have to allow for the current contents of the
# temporary file, which is why the result is 14 and not 12
exec /bin/sh -c \
{for a in 1 2 3; do sleep 1; echo $a; done} >>$tmpfile &
exec /bin/sh -c \
{for a in a b c; do sleep 1; echo $a; done} >>$tmpfile &
# The above two shell invokations take about 3 seconds to
# finish, so allow 5s (in case the machine is busy)
after 5000
# Check that no bytes have got lost through mixups with
# overlapping appends, which is only guaranteed to work when
# we set O_APPEND on the file descriptor in the [exec >>...]
file size $tmpfile
}
-cleanup {
removeFile $tmpfile
}
-result 14
}
# cleanup
foreach file {script gorp.file gorp.file2 echo cat wc sh sleep exit err} {
removeFile $file
}
unset -nocomplain path
::tcltest::cleanupTests
return
|
Changes to tests/execute.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: execute.test,v 1.13.2.2 2004/10/28 00:01:07 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {eval namespace delete [namespace children :: test_ns_*]}
|
| ︙ | ︙ | |||
708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
} 0
test execute-7.33 {Wide int handling} {longIs32bit} {
expr {0x1 * 1024 * 1024 * 1024 * 1024}
} 0
test execute-7.34 {Wide int handling} {longIs32bit} {
expr {wide(0x1) * 1024 * 1024 * 1024 * 1024}
} 1099511627776
# cleanup
if {[info commands testobj] != {}} {
testobj freeallvars
}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
| > > > > > > > > > > > > | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 |
} 0
test execute-7.33 {Wide int handling} {longIs32bit} {
expr {0x1 * 1024 * 1024 * 1024 * 1024}
} 0
test execute-7.34 {Wide int handling} {longIs32bit} {
expr {wide(0x1) * 1024 * 1024 * 1024 * 1024}
} 1099511627776
test execute-8.1 {Stack protection} -setup {
# If [Bug #804681] has not been properly
# taken care of, this should segfault
proc whatever args {llength $args}
trace add variable ::errorInfo {write unset} whatever
} -body {
expr {1+9/0}
} -cleanup {
trace remove variable ::errorInfo {write unset} whatever
rename whatever {}
} -returnCodes error -match glob -result *
# cleanup
if {[info commands testobj] != {}} {
testobj freeallvars
}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
|
| ︙ | ︙ |
Changes to tests/expr-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr-old.test,v 1.16.2.5 2006/05/04 12:34:39 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
test expr-old-4.20 {string operators} {expr {"abd" eq "abd"}} 1
test expr-old-4.21 {string operators} {expr {"abc" ne "abd"}} 1
test expr-old-4.22 {string operators} {expr {"abd" ne "abd"}} 0
test expr-old-4.23 {string operators} {expr {"" eq "abd"}} 0
test expr-old-4.24 {string operators} {expr {"" eq ""}} 1
test expr-old-4.25 {string operators} {expr {"abd" ne ""}} 1
test expr-old-4.26 {string operators} {expr {"" ne ""}} 0
| | | | | | | | 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
test expr-old-4.20 {string operators} {expr {"abd" eq "abd"}} 1
test expr-old-4.21 {string operators} {expr {"abc" ne "abd"}} 1
test expr-old-4.22 {string operators} {expr {"abd" ne "abd"}} 0
test expr-old-4.23 {string operators} {expr {"" eq "abd"}} 0
test expr-old-4.24 {string operators} {expr {"" eq ""}} 1
test expr-old-4.25 {string operators} {expr {"abd" ne ""}} 1
test expr-old-4.26 {string operators} {expr {"" ne ""}} 0
test expr-old-4.27 {string operators} {expr {"longerstring" eq "shorter"}} 0
test expr-old-4.28 {string operators} {expr {"longerstring" ne "shorter"}} 1
# The following tests are non-portable because on some systems "+"
# and "-" can be parsed as numbers.
test expr-old-4.29 {string operators} {nonPortable} {expr {"0" == "+"}} 0
test expr-old-4.30 {string operators} {nonPortable} {expr {"0" == "-"}} 0
test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo
test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar
# Operators that aren't legal on string operands.
test expr-old-5.1 {illegal string operations} {
list [catch {expr {-"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test expr-old-5.2 {illegal string operations} {
|
| ︙ | ︙ | |||
807 808 809 810 811 812 813 |
list [catch {expr rand(24)} msg] $msg
} {1 {too many arguments for math function}}
test expr-old-32.47 {math functions in expressions} {
list [catch {expr srand()} msg] $msg
} {1 {too few arguments for math function}}
test expr-old-32.48 {math functions in expressions} {
list [catch {expr srand(3.79)} msg] $msg
| | | | 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
list [catch {expr rand(24)} msg] $msg
} {1 {too many arguments for math function}}
test expr-old-32.47 {math functions in expressions} {
list [catch {expr srand()} msg] $msg
} {1 {too few arguments for math function}}
test expr-old-32.48 {math functions in expressions} {
list [catch {expr srand(3.79)} msg] $msg
} {1 {expected integer but got "3.79"}}
test expr-old-32.49 {math functions in expressions} {
list [catch {expr srand("")} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-32.50 {math functions in expressions} {
set result [expr round(srand(12345) * 1000)]
for {set i 0} {$i < 10} {incr i} {
lappend result [expr round(rand() * 1000)]
}
set result
} {97 834 948 36 12 51 766 585 914 784 333}
test expr-old-32.51 {math functions in expressions} {
list [catch {expr {srand([lindex "6ty" 0])}} msg] $msg
} {1 {argument to math function didn't have numeric value}}
test expr-old-32.52 {math functions in expressions} {
expr {srand(int(1<<37)) < 1}
} {1}
test expr-old-32.53 {math functions in expressions} {
expr {srand((1<<31) - 1) > 0}
} {1}
test expr-old-33.1 {conversions and fancy args to math functions} {
expr hypot ( 3 , 4 )
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 |
} else {
test expr-old-38.1 {Verify Tcl_ExprString's basic operation} {
list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \
[catch {testexprstring "1+"} msg] $msg
} {5 10.2 1 {syntax error in expression "1+": premature end of expression}}
}
# Special test for Pentium arithmetic bug of 1994:
if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
puts "Warning: this machine contains a defective Pentium processor"
puts "that performs arithmetic incorrectly. I recommend that you"
puts "call Intel customer service immediately at 1-800-628-8686"
puts "to request a replacement processor."
}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > | 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 |
} else {
test expr-old-38.1 {Verify Tcl_ExprString's basic operation} {
list [testexprstring "1+4"] [testexprstring "2*3+4.2"] \
[catch {testexprstring "1+"} msg] $msg
} {5 10.2 1 {syntax error in expression "1+": premature end of expression}}
}
#
# Test for bug #908375: rounding numbers that do not fit in a
# long but do fit in a wide
#
test expr-old-39.1 {Rounding with wide result} {
set x 1.0e10
set y [expr $x + 0.1]
catch {
set x [list [expr {$x == round($y)}] [expr $x == -round(-$y)]]
}
set x
} {1 1}
unset -nocomplain x y
# Special test for Pentium arithmetic bug of 1994:
if {(4195835.0 - (4195835.0/3145727.0)*3145727.0) == 256.0} {
puts "Warning: this machine contains a defective Pentium processor"
puts "that performs arithmetic incorrectly. I recommend that you"
puts "call Intel customer service immediately at 1-800-628-8686"
puts "to request a replacement processor."
}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/expr.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: expr # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
# Commands covered: expr
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: expr.test,v 1.17.2.12 2006/03/23 16:40:32 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint registeredMathFuncs [expr {
([catch {expr T1()} msg] != 1) || ($msg ne {unknown math function "T1"})
}]
testConstraint wideIs64bit [expr {(0x80000000 > 0) && (0x8000000000000000 < 0)}]
# procedures used below
proc put_hello_char {c} {
global a
append a [format %c $c]
return $c
}
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
catch {expr 2**3==6} msg
set msg
} {syntax error in expression "2**3==6": unexpected operator *}
test expr-8.11 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2!=x} msg
set msg
} {syntax error in expression "2!=x": variable references require preceding $}
| | | | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
catch {expr 2**3==6} msg
set msg
} {syntax error in expression "2**3==6": unexpected operator *}
test expr-8.11 {CompileEqualityExpr: error compiling equality arm} {
catch {expr 2!=x} msg
set msg
} {syntax error in expression "2!=x": variable references require preceding $}
test expr-8.12 {CompileBitAndExpr: equality expr} {expr {"a"eq"a"}} 1
test expr-8.13 {CompileBitAndExpr: equality expr} {expr {"\374" eq "ü"}} 1
test expr-8.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-8.15 {CompileBitAndExpr: equality expr} {expr 2.0eq2} 0
test expr-8.16 {CompileBitAndExpr: equality expr} {expr 3.2ne2.2} 1
test expr-8.17 {CompileBitAndExpr: equality expr} {expr 01eq1} 0
test expr-8.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-8.19 {CompileBitAndExpr: equality expr} {expr {"abc" ne "abd"}} 1
test expr-8.20 {CompileBitAndExpr: error in equality expr} {
|
| ︙ | ︙ | |||
801 802 803 804 805 806 807 808 809 810 811 812 813 814 |
} {1 {floating-point value too large to represent}}
test expr-22.7 {non-numeric floats} nonPortable {
list [catch {expr {1 / NaN}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "/"}}
test expr-22.8 {non-numeric floats} nonPortable {
list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}
# cleanup
if {[info exists a]} {
unset a
}
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 |
} {1 {floating-point value too large to represent}}
test expr-22.7 {non-numeric floats} nonPortable {
list [catch {expr {1 / NaN}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "/"}}
test expr-22.8 {non-numeric floats} nonPortable {
list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}
# Make sure [Bug 761471] stays fixed.
test expr-22.9 {non-numeric floats: shared object equality and NaN} nonPortable {
set x NaN
expr {$x == $x}
} 0
# Some compilers get this wrong; ensure that we work around it correctly
test expr-24.1 {expr edge cases; shifting} {expr int(5)>>31} 0
test expr-24.2 {expr edge cases; shifting} {expr int(5)>>63} 0
test expr-24.3 {expr edge cases; shifting} {expr wide(5)>>31} 0
test expr-24.4 {expr edge cases; shifting} {expr wide(5)>>63} 0
test expr-24.5 {expr edge cases; shifting} nonPortable {expr int(5)<<31} 0
test expr-24.6 {expr edge cases; shifting} nonPortable {expr int(5)<<63} 0
test expr-24.7 {expr edge cases; shifting} {expr wide(5)<<31} 10737418240
test expr-24.8 {expr edge cases; shifting} nonPortable {expr wide(5)<<63} -9223372036854775808
test expr-24.9 {expr edge cases; shifting} {expr 5>>32} 0
test expr-38.1 {abs of smallest 32-bit integer [Bug 1241572]} {wideIs64bit} {
expr {abs(int(-2147483648))}
} 2147483648
test expr-46.1 {round() rounds to +-infinity} {
expr round(0.5)
} 1
test expr-46.2 {round() rounds to +-infinity} {
expr round(1.5)
} 2
test expr-46.3 {round() rounds to +-infinity} {
expr round(-0.5)
} -1
test expr-46.4 {round() rounds to +-infinity} {
expr round(-1.5)
} -2
test expr-46.5 {round() overflow} {
list [catch {expr round(9.2233720368547758e+018)} result] $result
} {1 {integer value too large to represent}}
test expr-46.6 {round() overflow} {
list [catch {expr round(-9.2233720368547758e+018)} result] $result
} {1 {integer value too large to represent}}
test expr-46.7 {round() bad value} {
set x trash
list [catch {expr {round($x)}} result] $result
} {1 {argument to math function didn't have numeric value}}
test expr-46.8 {round() already an integer} {
set x 123456789012
incr x
expr round($x)
} 123456789013
test expr-46.9 {round() boundary case - 1/2 - 1 ulp} {
set x 0.25
set bit 0.125
while 1 {
set newx [expr {$x + $bit}]
if { $newx == $x || $newx == 0.5 } break
set x $newx
set bit [expr { $bit / 2.0 }]
}
expr {round($x)}
} 0
test expr-46.10 {round() boundary case - 1/2 + 1 ulp} {
set x 0.75
set bit 0.125
while 1 {
set newx [expr { $x - $bit }]
if { $newx == $x || $newx == 0.5 } break
set x $newx
set bit [expr { $bit / 2.0 }]
}
expr {round($x)}
} 1
test expr-46.11 {round() boundary case - -1/2 - 1 ulp} {
set x -0.75
set bit 0.125
while 1 {
set newx [expr { $x + $bit }]
if { $newx == $x || $newx == -0.5 } break
set x $newx
set bit [expr { $bit / 2.0 }]
}
expr {round($x)}
} -1
test expr-46.12 {round() boundary case - -1/2 + 1 ulp} {
set x -0.25
set bit 0.125
while 1 {
set newx [expr { $x - $bit }]
if { $newx == $x || $newx == -0.5 } break
set x $newx
set bit [expr { $bit / 2.0 }]
}
expr {round($x)}
} 0
test expr-46.13 {round() boundary case - round down} {
expr {round(2147483647 - 0.51)}
} 2147483646
test expr-46.14 {round() boundary case - round up} {
expr {round(2147483647 - 0.50)}
} 2147483647
test expr-46.15 {round() boundary case - round up to wide} {
expr {round(2147483647 + 0.50)}
} [expr {wide(2147483647) + 1}]
test expr-46.16 {round() boundary case - round up} {
expr {round(-2147483648 + 0.51)}
} -2147483647
test expr-46.17 {round() boundary case - round down} {
expr {round(-2147483648 + 0.50)}
} -2147483648
test expr-46.18 {round() boundary case - round down to wide} {
expr {round(-2147483648 - 0.50)}
} [expr {wide(-2147483648) - 1}]
# cleanup
if {[info exists a]} {
unset a
}
::tcltest::cleanupTests
return
|
Changes to tests/fCmd.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclFCmd.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
# This file tests the tclFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fCmd.test,v 1.26.2.9 2007/05/17 14:18:42 dgp Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
tcltest::testConstraint testchmod [string equal testchmod [info commands testchmod]]
tcltest::testConstraint notNetworkFilesystem 0
testConstraint 95or98 [expr {[testConstraint 95] || [testConstraint 98]}]
testConstraint 2000orNewer [expr {![testConstraint 95or98]}]
# Several tests require need to match results against the unix username
set user {}
if {$tcl_platform(platform) == "unix"} {
catch {set user [exec whoami]}
if {$user == ""} {
catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
|
| ︙ | ︙ | |||
90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
proc contents {file} {
set f [open $file r]
set r [read $f]
close $f
set r
}
set ::tcltest::testConstraints(fileSharing) 0
set ::tcltest::testConstraints(notFileSharing) 1
if {$tcl_platform(platform) == "macintosh"} {
catch {file delete -force foo.dir}
file mkdir foo.dir
| > > | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
proc contents {file} {
set f [open $file r]
set r [read $f]
close $f
set r
}
cd [temporaryDirectory]
set ::tcltest::testConstraints(fileSharing) 0
set ::tcltest::testConstraints(notFileSharing) 1
if {$tcl_platform(platform) == "macintosh"} {
catch {file delete -force foo.dir}
file mkdir foo.dir
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
} [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}]
test fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} {notRoot} {
cleanup
createfile tf1
file mkdir [file join td1 tf1]
list [catch {file rename -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
| | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 |
} [subst {1 {can't overwrite file "[file join td2 td1]" with directory "td1"}}]
test fCmd-6.14 {CopyRenameOneFile: source is file, target is dir} {notRoot} {
cleanup
createfile tf1
file mkdir [file join td1 tf1]
list [catch {file rename -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
test fCmd-6.15 {CopyRenameOneFile: TclpRenameFile succeeds} {notRoot notNetworkFilesystem} {
cleanup
file mkdir [file join td1 td2]
file mkdir td2
createfile [file join td2 tf1]
file rename -force td2 td1
file exists [file join td1 td2 tf1]
} {1}
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
# Labelled knownBug because it is dangerous [Bug: 3881]
file mkdir td1
file attr td1 -perm 040000
set result [list [catch {file rename ~$user td1} msg] $msg]
file delete -force td1
set result
} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}"
| | < | | > > > > > | 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
# Labelled knownBug because it is dangerous [Bug: 3881]
file mkdir td1
file attr td1 -perm 040000
set result [list [catch {file rename ~$user td1} msg] $msg]
file delete -force td1
set result
} "1 {error renaming \"~$user\" to \"td1/[file tail ~$user]\": permission denied}"
test fCmd-8.2 {FileBasename: basename of ~user: argc == 1 && *path == ~} {
string equal [file tail ~$user] ~$user
} 0
test fCmd-8.3 {file copy and path translation: ensure correct error} {
list [catch {file copy ~ [file join this file doesnt exist]} res] $res
} [list 1 \
"error copying \"~\" to \"[file join this file doesnt exist]\":\
no such file or directory"]
test fCmd-9.1 {file rename: comprehensive: EACCES} {unixOnly notRoot} {
cleanup
file mkdir td1
file mkdir td2
file attr td2 -perm 040000
set result [list [catch {file rename td1 td2/} msg] $msg]
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 |
set msg [list [catch {file rename tf1 tf2} msg] $msg]
file rename -force tfs1 tfd1
file rename -force tfs2 tfd2
file rename -force tfs3 tfd3
file rename -force tfs4 tfd4
list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4]
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
| | | 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 |
set msg [list [catch {file rename tf1 tf2} msg] $msg]
file rename -force tfs1 tfd1
file rename -force tfs2 tfd2
file rename -force tfs3 tfd3
file rename -force tfs4 tfd4
list [lsort [glob tf*]] $msg [file writable tfd1] [file writable tfd2] [file writable tfd3] [file writable tfd4]
} {{tf1 tf2 tfd1 tfd2 tfd3 tfd4} {1 {error renaming "tf1" to "tf2": file already exists}} 1 1 0 0}
test fCmd-9.8 {file rename: comprehensive: dir to empty dir} {notRoot testchmod notNetworkFilesystem} {
# Under unix, you can rename a read-only directory, but you can't
# move it into another directory.
cleanup
file mkdir td1
file mkdir [file join td2 td1]
file mkdir tds1
|
| ︙ | ︙ | |||
827 828 829 830 831 832 833 |
set w4 [file writable [file join td3 td4]]
} else {
set w4 0
}
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
[file writable [file join td3 td3]] $w4
} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]
| | | 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 |
set w4 [file writable [file join td3 td4]]
} else {
set w4 0
}
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
[file writable [file join td3 td3]] $w4
} [subst {td3 {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-9.12 {file rename: comprehensive: target exists} {notRoot testchmod notNetworkFilesystem} {
cleanup
file mkdir [file join td1 td2] [file join td2 td1]
if {$tcl_platform(platform) != "macintosh"} {
testchmod 555 [file join td2 td1]
}
file mkdir [file join td3 td4] [file join td4 td3]
file rename -force td3 td4
|
| ︙ | ︙ | |||
880 881 882 883 884 885 886 |
createfile tf1 tf1
createfile tf2 tf2
testchmod 444 tf2
file copy tf1 tf3
file copy tf2 tf4
list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0}
| | > > > > > > > > > > > > > > | 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
createfile tf1 tf1
createfile tf2 tf2
testchmod 444 tf2
file copy tf1 tf3
file copy tf2 tf4
list [lsort [glob tf*]] [contents tf3] [contents tf4] [file writable tf3] [file writable tf4]
} {{tf1 tf2 tf3 tf4} tf1 tf2 1 0}
test fCmd-10.3 {file copy: comprehensive: dir to new name} {notRoot unixOrPc 95or98 testchmod} {
cleanup
file mkdir [file join td1 tdx]
file mkdir [file join td2 tdy]
testchmod 555 td2
file copy td1 td3
file copy td2 td4
set msg [list [lsort [glob td*]] [glob -directory td3 t*] \
[glob -directory td4 t*] [file writable td3] [file writable td4]]
if {$tcl_platform(platform) != "macintosh"} {
testchmod 755 td2
testchmod 755 td4
}
set msg
} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 0}]
test fCmd-10.3.1 {file copy: comprehensive: dir to new name} {notRoot pc 2000orNewer testchmod} {
# On Windows with ACLs, copying a directory is defined like this
cleanup
file mkdir [file join td1 tdx]
file mkdir [file join td2 tdy]
testchmod 555 td2
file copy td1 td3
file copy td2 td4
set msg [list [lsort [glob td*]] [glob -directory td3 t*] \
[glob -directory td4 t*] [file writable td3] [file writable td4]]
testchmod 755 td2
testchmod 755 td4
set msg
} [subst {{td1 td2 td3 td4} [file join td3 tdx] [file join td4 tdy] 1 1}]
test fCmd-10.4 {file copy: comprehensive: file to existing file} {notRoot testchmod} {
cleanup
createfile tf1
createfile tf2
createfile tfs1
createfile tfs2
createfile tfs3
|
| ︙ | ︙ | |||
967 968 969 970 971 972 973 |
testchmod 444 tf2
file copy tf1 [file join td1 tf3]
file copy tf2 [file join td1 tf4]
list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \
[file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \
| | > > > > > > > > > > > > > > > > > > > > > > > | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
testchmod 444 tf2
file copy tf1 [file join td1 tf3]
file copy tf2 [file join td1 tf4]
list [lsort [glob tf*]] [lsort [glob -directory td1 t*]] \
[file writable [file join td1 tf3]] [file writable [file join td1 tf4]]
} [subst {{tf1 tf2} {[file join td1 tf3] [file join td1 tf4]} 1 0}]
test fCmd-10.8 {file rename: comprehensive: dir to new name and dir} \
{notRoot unixOrPc 95or98 testchmod} {
cleanup
file mkdir td1
file mkdir td2
file mkdir td3
testchmod 555 td2
file copy td1 [file join td3 td3]
file copy td2 [file join td3 td4]
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
[file writable [file join td3 td3]] [file writable [file join td3 td4]]
} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 0}]
test fCmd-10.8.1 {file rename: comprehensive: dir to new name and dir} \
{notRoot pc 2000orNewer testchmod} {
# On Windows with ACLs, copying a directory is defined like this
cleanup
file mkdir td1
file mkdir td2
file mkdir td3
testchmod 555 td2
file copy td1 [file join td3 td3]
file copy td2 [file join td3 td4]
list [lsort [glob td*]] [lsort [glob -directory td3 t*]] \
[file writable [file join td3 td3]] [file writable [file join td3 td4]]
} [subst {{td1 td2 td3} {[file join td3 td3] [file join td3 td4]} 1 1}]
test fCmd-10.9 {file copy: comprehensive: source and target incompatible} \
{notRoot} {
cleanup
file mkdir td1
createfile tf1
list [catch {file copy -force td1 tf1} msg] $msg
} {1 {can't overwrite file "tf1" with directory "td1"}}
test fCmd-10.10 {file copy: comprehensive: source and target incompatible} \
{notRoot} {
cleanup
file mkdir [file join td1 tf1]
createfile tf1
list [catch {file copy -force tf1 td1} msg] $msg
} [subst {1 {can't overwrite directory "[file join td1 tf1]" with file "tf1"}}]
test fCmd-10.11 {file copy: copy to empty file name} {
cleanup
createfile tf1
list [catch {file copy tf1 ""} msg] $msg
} {1 {error copying "tf1" to "": no such file or directory}}
test fCmd-10.12 {file rename: rename to empty file name} {
cleanup
createfile tf1
list [catch {file rename tf1 ""} msg] $msg
} {1 {error renaming "tf1" to "": no such file or directory}}
cleanup
# old tests
test fCmd-11.1 {TclFileRenameCmd: -- option } {notRoot} {
catch {file delete -force -- -tfa1}
set s [createfile -tfa1]
|
| ︙ | ︙ | |||
1653 1654 1655 1656 1657 1658 1659 |
set r1 [catch {file rename tfa tfad}]
set result [expr $r1 && [file isdir tfa]]
file delete -force tfa tfad
set result
} {1}
test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} \
| | | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 |
set r1 [catch {file rename tfa tfad}]
set result [expr $r1 && [file isdir tfa]]
file delete -force tfa tfad
set result
} {1}
test fCmd-18.8 {TclFileRenameCmd: rename dir on top of another empty dir w/ -force} \
{notRoot notNetworkFilesystem} {
catch {file delete -force -- tfa tfad}
file mkdir tfa tfad/tfa
file rename -force tfa tfad
set result [expr ![file isdir tfa]]
file delete -force tfad
set result
} {1}
test fCmd-18.9 {TclFileRenameCmd: rename dir on top of a non-empty dir w/o -force} \
{notRoot} {
catch {file delete -force -- tfa tfad}
file mkdir tfa tfad/tfa/file
set r1 [catch {file rename tfa tfad}]
set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
file delete -force tfa tfad
set result
} {1}
test fCmd-18.10 {TclFileRenameCmd: rename dir on top of a non-empty dir w/ -force} \
{notRoot notNetworkFilesystem} {
catch {file delete -force -- tfa tfad}
file mkdir tfa tfad/tfa/file
set r1 [catch {file rename -force tfa tfad}]
set result [expr $r1 && [file isdir tfa] && [file isdir tfad/tfa/file]]
file delete -force tfa tfad
set result
} {1}
|
| ︙ | ︙ | |||
1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 |
file attributes tfa/a -permissions 0000
set result [catch {file delete -force tfa}]
file attributes tfa/a -permissions 0777
file delete -force tfa
set result
} {1}
#
# Feature testing for TclCopyFilesCmd
#
test fCmd-21.1 {copy : single file to nonexistant } {notRoot} {
catch {file delete -force -- tfa1 tfa2}
set s [createfile tfa1]
| > > > > > > > > > | 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 |
file attributes tfa/a -permissions 0000
set result [catch {file delete -force tfa}]
file attributes tfa/a -permissions 0777
file delete -force tfa
set result
} {1}
test fCmd-20.2 {TraverseUnixTree : recursive delete of large directory: Bug 1034337} \
{unix notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
for {set i 1} {$i <= 300} {incr i} {createfile tfa/testfile_$i}
set result [catch {file delete -force tfa} msg]
while {[catch {file delete -force tfa}]} {}
list $result $msg
} {0 {}}
#
# Feature testing for TclCopyFilesCmd
#
test fCmd-21.1 {copy : single file to nonexistant } {notRoot} {
catch {file delete -force -- tfa1 tfa2}
set s [createfile tfa1]
|
| ︙ | ︙ | |||
2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 |
test fCmd-28.3 {file link} {
list [catch {file link abc b c} msg] $msg
} {1 {bad switch "abc": must be -symbolic or -hard}}
test fCmd-28.4 {file link} {
list [catch {file link -abc b c} msg] $msg
} {1 {bad switch "-abc": must be -symbolic or -hard}}
makeDirectory abc.dir
makeDirectory abc2.dir
makeFile contents abc.file
makeFile contents abc2.file
cd [temporaryDirectory]
| > | 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 |
test fCmd-28.3 {file link} {
list [catch {file link abc b c} msg] $msg
} {1 {bad switch "abc": must be -symbolic or -hard}}
test fCmd-28.4 {file link} {
list [catch {file link -abc b c} msg] $msg
} {1 {bad switch "-abc": must be -symbolic or -hard}}
cd [workingDirectory]
makeDirectory abc.dir
makeDirectory abc2.dir
makeFile contents abc.file
makeFile contents abc2.file
cd [temporaryDirectory]
|
| ︙ | ︙ | |||
2343 2344 2345 2346 2347 2348 2349 |
file copy abc2.file abc.dir
cd [workingDirectory]
test fCmd-28.16 {file link: glob inside link} {linkDirectory} {
cd [temporaryDirectory]
file delete -force abc.link
file link abc.link abc.dir
| | | | 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 |
file copy abc2.file abc.dir
cd [workingDirectory]
test fCmd-28.16 {file link: glob inside link} {linkDirectory} {
cd [temporaryDirectory]
file delete -force abc.link
file link abc.link abc.dir
set res [lsort [glob -dir abc.link -tails *]]
cd [workingDirectory]
set res
} [lsort [list abc.file abc2.file]]
test fCmd-28.17 {file link: glob -type l} {linkDirectory} {
cd [temporaryDirectory]
set res [glob -dir [pwd] -type l -tails abc*]
cd [workingDirectory]
set res
} {abc.link}
|
| ︙ | ︙ |
Changes to tests/fileName.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the filename manipulation routines. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the filename manipulation routines.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: fileName.test,v 1.30.2.7 2005/06/21 19:07:58 kennykb Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
|
| ︙ | ︙ | |||
327 328 329 330 331 332 333 |
regsub -all ":" $norm "/" norm
# make sure we can delete the directory we created
cd $oldDir
file delete -force $nastydir
set norm
} err]
cd $oldDir
| | | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
regsub -all ":" $norm "/" norm
# make sure we can delete the directory we created
cd $oldDir
file delete -force $nastydir
set norm
} err]
cd $oldDir
catch {file delete -force [file join [temporaryDirectory] tildetmp]}
list $res $err
} {0 tildetmp/~tilde}
test filename-5.1 {Tcl_SplitPath: mac} {testsetplatform} {
testsetplatform mac
file split a:b
} {a: b}
|
| ︙ | ︙ | |||
891 892 893 894 895 896 897 898 899 900 901 902 903 904 |
testsetplatform win
file join foo .. bar
} {foo/../bar}
test filename-9.18 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join foo/./bar
} {foo/./bar}
test filename-10.1 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform unix
list [catch {testtranslatefilename foo} msg] $msg
} {0 foo}
test filename-10.2 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform windows
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 |
testsetplatform win
file join foo .. bar
} {foo/../bar}
test filename-9.18 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
file join foo/./bar
} {foo/./bar}
test filename-9.19 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
set res {}
lappend res \
[file join {C:\foo\bar}] \
[file join C:/blah {C:\foo\bar}] \
[file join C:/blah C:/blah {C:\foo\bar}]
} {C:/foo/bar C:/foo/bar C:/foo/bar}
test filename-9.19.1 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
set res {}
lappend res \
[file join {foo\bar}] \
[file join C:/blah {foo\bar}] \
[file join C:/blah C:/blah {foo\bar}]
} {foo/bar C:/blah/foo/bar C:/blah/foo/bar}
test filename-9.19.2 {Tcl_JoinPath: win} {testsetplatform winOnly} {
testsetplatform win
set res {}
lappend res \
[file join {foo\bar}] \
[file join [pwd] {foo\bar}] \
[file join [pwd] [pwd] {foo\bar}]
string map [list [pwd] pwd] $res
} {foo/bar pwd/foo/bar pwd/foo/bar}
test filename-9.20 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
set res {}
lappend res \
[file join {/foo/bar}] \
[file join /x {/foo/bar}] \
[file join /x /x {/foo/bar}]
} {/foo/bar /foo/bar /foo/bar}
test filename-9.21 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
set res {}
lappend res \
[file join {/foo/bar}] \
[file join drive: {/foo/bar}] \
[file join drive: drive: {/foo/bar}]
} {foo:bar foo:bar foo:bar}
test filename-9.22 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
set res {}
lappend res \
[file join {foo:bar}] \
[file join drive: {foo:bar}] \
[file join drive: drive: {foo:bar}]
} {foo:bar foo:bar foo:bar}
test filename-9.23 {Tcl_JoinPath: win} {testsetplatform} {
testsetplatform win
set res {}
lappend res \
[file join {foo\bar}] \
[file join C:/blah {foo\bar}] \
[file join C:/blah C:/blah {foo\bar}]
string map [list C:/blah ""] $res
} {foo/bar /foo/bar /foo/bar}
test filename-9.24 {Tcl_JoinPath: unix} {testsetplatform} {
testsetplatform unix
set res {}
lappend res \
[file join {foo/bar}] \
[file join /x {foo/bar}] \
[file join /x /x {foo/bar}]
string map [list /x ""] $res
} {foo/bar /foo/bar /foo/bar}
test filename-9.25 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
set res {}
lappend res \
[file join {foo/bar}] \
[file join drive: {foo/bar}] \
[file join drive: drive: {foo/bar}]
string map [list drive: ""] $res
} {:foo:bar foo:bar foo:bar}
test filename-9.26 {Tcl_JoinPath: mac} {testsetplatform} {
testsetplatform mac
set res {}
lappend res \
[file join {:foo:bar}] \
[file join drive: {:foo:bar}] \
[file join drive: drive: {:foo:bar}]
string map [list drive: ""] $res
} {:foo:bar foo:bar foo:bar}
test filename-10.1 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform unix
list [catch {testtranslatefilename foo} msg] $msg
} {0 foo}
test filename-10.2 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform windows
|
| ︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 |
list [catch {lsort [glob -type d -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]]
test filename-11.21 {Tcl_GlobCmd} {
list [catch {lsort [glob -type d -path $globname *]} msg] $msg
} [list 0 [lsort [list $globname]]]
# Get rid of file/dir if it exists, since it will have
# been left behind by a previous failed run.
if {[file exists $horribleglobname]} {
file delete -force $horribleglobname
}
file rename globTest $horribleglobname
| > > > > > > > | 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 |
list [catch {lsort [glob -type d -dir $globname *]} msg] $msg
} [list 0 [lsort [list [file join $globname a1]\
[file join $globname a2]\
[file join $globname a3]]]]
test filename-11.21 {Tcl_GlobCmd} {
list [catch {lsort [glob -type d -path $globname *]} msg] $msg
} [list 0 [lsort [list $globname]]]
test filename-11.21.1 {Tcl_GlobCmd} {
close [open {[tcl].testremains} w]
set res [list [catch {lsort [glob -path {[tcl]} *]} msg] $msg]
file delete -force {[tcl].testremains}
set res
} [list 0 {{[tcl].testremains}}]
# Get rid of file/dir if it exists, since it will have
# been left behind by a previous failed run.
if {[file exists $horribleglobname]} {
file delete -force $horribleglobname
}
file rename globTest $horribleglobname
|
| ︙ | ︙ | |||
1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 |
} "$globPreResult$x1 $globPreResult$y1"
test filename-12.5 {simple globbing} {
list [catch {glob globTest\\/x1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-12.6 {simple globbing} {
list [catch {glob globTest\\/\\x1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-13.1 {globbing with brace substitution} {
list [catch {glob globTest/\{\}} msg] $msg
} "0 $globPreResult"
test filename-13.2 {globbing with brace substitution} {
list [catch {glob globTest/\{} msg] $msg
} {1 {unmatched open-brace in file name}}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 |
} "$globPreResult$x1 $globPreResult$y1"
test filename-12.5 {simple globbing} {
list [catch {glob globTest\\/x1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-12.6 {simple globbing} {
list [catch {glob globTest\\/\\x1.c} msg] $msg
} "0 $globPreResult$x1"
test filename-12.7 {globbing at filesystem root} {unixOnly} {
set res1 [glob -nocomplain /*]
set res2 [glob -path / *]
set equal [string equal $res1 $res2]
if {!$equal} {
lappend equal "not equal" $res1 $res2
}
set equal
} {1}
test filename-12.8 {globbing at filesystem root} {unixOnly} {
set dir [lindex [glob -type d /*] 0]
set first [string range $dir 0 1]
set res1 [glob -nocomplain ${first}*]
set res2 [glob -path $first *]
set equal [string equal $res1 $res2]
if {!$equal} {
lappend equal "not equal" $res1 $res2
}
set equal
} {1}
test filename-12.9 {globbing at filesystem root} {winOnly} {
# Can't grab just anything from 'file volumes' because we need a dir
# that has subdirs - assume that C:/ exists across Windows machines.
set dir [lindex [glob -type d C:/*] 0]
set first [string range $dir 0 3]
set res1 [glob -nocomplain ${first}*]
set res2 [glob -path $first *]
set equal [string equal $res1 $res2]
if {!$equal} {
lappend equal "not equal" $res1 $res2
}
set equal
} {1}
test filename-13.1 {globbing with brace substitution} {
list [catch {glob globTest/\{\}} msg] $msg
} "0 $globPreResult"
test filename-13.2 {globbing with brace substitution} {
list [catch {glob globTest/\{} msg] $msg
} {1 {unmatched open-brace in file name}}
|
| ︙ | ︙ | |||
1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 |
set res [glob -nocomplain -dir [temporaryDirectory]/execglob \
-tails -types x *]
removeFile execglob/abc.exe
removeFile execglob/abc.notexecutable
removeDirectory execglob
set res
} {abc.exe}
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome
| > > > > > > > | 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 |
set res [glob -nocomplain -dir [temporaryDirectory]/execglob \
-tails -types x *]
removeFile execglob/abc.exe
removeFile execglob/abc.notexecutable
removeDirectory execglob
set res
} {abc.exe}
test fileName-18.1 {windows - split ADS name correctly} {winOnly} {
# bug 1194458
set x [file split c:/c:d]
set y [eval [linsert $x 0 file join]]
list $x $y
} {{c:/ ./c:d} c:/c:d}
# cleanup
catch {file delete -force C:/globTest}
cd [temporaryDirectory]
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome
|
| ︙ | ︙ |
Changes to tests/fileSystem.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file tests the filesystem and vfs internals. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 2002 Vincent Darley. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
# This file tests the filesystem and vfs internals.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2002 Vincent Darley.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest 2
namespace eval ::tcl::test::fileSystem {
catch {
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::makeDirectory
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeDirectory
namespace import ::tcltest::removeFile
namespace import ::tcltest::test
}
catch {
file delete -force link.file
file delete -force dir.link
file delete -force [file join dir.file linkinside.file]
}
cd [tcltest::temporaryDirectory]
makeFile "test file" gorp.file
makeDirectory dir.file
makeFile "test file in directory" [file join dir.file inside.file]
if {[catch {
file link link.file gorp.file
file link \
[file join dir.file linkinside.file] \
[file join dir.file inside.file]
file link dir.link dir.file
}]} {
tcltest::testConstraint hasLinks 0
} else {
tcltest::testConstraint hasLinks 1
}
tcltest::testConstraint testsimplefilesystem \
[string equal testsimplefilesystem [info commands testsimplefilesystem]]
test filesystem-1.0 {link normalisation} {hasLinks} {
string equal [file normalize gorp.file] [file normalize link.file]
} {0}
test filesystem-1.1 {link normalisation} {hasLinks} {
string equal [file normalize dir.file] [file normalize dir.link]
} {0}
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
list [catch {file writable ""} msg] $msg
} {0 0}
# Make sure the testfilesystem hasn't been registered.
while {![catch {testfilesystem 0}]} {}
}
| | | > | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 |
list [catch {file writable ""} msg] $msg
} {0 0}
# Make sure the testfilesystem hasn't been registered.
while {![catch {testfilesystem 0}]} {}
}
test filesystem-7.1 {load from vfs} {win testsimplefilesystem} {
# This may cause a crash on exit
set dir [pwd]
cd [file dirname [info nameof]]
set dde [lindex [glob *dde*[info sharedlib]] 0]
testsimplefilesystem 1
# This loads dde via a complex copy-to-temp operation
load simplefs:/$dde dde
testsimplefilesystem 0
cd $dir
set res "ok"
# The real result of this test is what happens when Tcl exits.
} {ok}
test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} \
{testsimplefilesystem} {
set dir [pwd]
cd [tcltest::temporaryDirectory]
# We created this file several tests ago.
set origtime [file mtime gorp.file]
testsimplefilesystem 1
file delete -force theCopy
file copy simplefs:/gorp.file theCopy
|
| ︙ | ︙ | |||
451 452 453 454 455 456 457 |
makeDirectory $dir
makeFile "contents" [file join abc foo]
cd $dir
set res [file exists [lindex [glob *] 0]]
cd ..
removeFile [file join abc foo]
removeDirectory abc
| < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 |
makeDirectory $dir
makeFile "contents" [file join abc foo]
cd $dir
set res [file exists [lindex [glob *] 0]]
cd ..
removeFile [file join abc foo]
removeDirectory abc
cd $origdir
set res
} {1}
test filesystem-8.3 {path objects and empty string} {
set anchor ""
set dst foo
set res $dst
set yyy [file split $anchor]
set dst [file join $anchor $dst]
lappend res $dst $yyy
} {foo foo {}}
proc TestFind1 {d f} {
set r1 [file exists [file join $d $f]]
lappend res "[file join $d $f] found: $r1"
lappend res "is dir a dir? [file isdirectory $d]"
set r2 [file exists [file join $d $f]]
lappend res "[file join $d $f] found: $r2"
set res
}
proc TestFind2 {d f} {
set r1 [file exists [file join $d $f]]
lappend res "[file join $d $f] found: $r1"
lappend res "is dir a dir? [file isdirectory [file join $d]]"
set r2 [file exists [file join $d $f]]
lappend res "[file join $d $f] found: $r2"
set res
}
test filesystem-9.1 {path objects and join and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
file mkdir [file join a b c]
set res [TestFind1 a [file join b . c]]
file delete -force a
cd $origdir
set res
} {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}}
test filesystem-9.2 {path objects and join and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
file mkdir [file join a b c]
set res [TestFind2 a [file join b . c]]
file delete -force a
cd $origdir
set res
} {{a/b/./c found: 1} {is dir a dir? 1} {a/b/./c found: 1}}
test filesystem-9.2.1 {path objects and join and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
file mkdir [file join a b c]
set res [TestFind2 a [file join b .]]
file delete -force a
cd $origdir
set res
} {{a/b/. found: 1} {is dir a dir? 1} {a/b/. found: 1}}
test filesystem-9.3 {path objects and join and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
file mkdir [file join a b c]
set res [TestFind1 a [file join b .. b c]]
file delete -force a
cd $origdir
set res
} {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}}
test filesystem-9.4 {path objects and join and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
file mkdir [file join a b c]
set res [TestFind2 a [file join b .. b c]]
file delete -force a
cd $origdir
set res
} {{a/b/../b/c found: 1} {is dir a dir? 1} {a/b/../b/c found: 1}}
test filesystem-9.5 {path objects and file tail and object rep} {
set origdir [pwd]
cd [tcltest::temporaryDirectory]
file mkdir dgp
close [open dgp/test w]
foreach relative [glob -nocomplain [file join * test]] {
set absolute [file join [pwd] $relative]
set res [list [file tail $absolute] "test"]
}
file delete -force dgp
cd $origdir
set res
} {test test}
test filesystem-9.6 {path objects and file join and object rep} {winOnly} {
set res {}
set p "C:\\toto"
lappend res [file join $p toto]
file isdirectory $p
lappend res [file join $p toto]
} {C:/toto/toto C:/toto/toto}
test filesystem-9.7 {path objects and glob and file tail and tilde} {
set res {}
set origdir [pwd]
cd [tcltest::temporaryDirectory]
file mkdir tilde
close [open tilde/~testNotExist w]
cd tilde
set file [lindex [glob *test*] 0]
lappend res [file exists $file] [catch {file tail $file} r] $r
lappend res $file
lappend res [file exists $file] [catch {file tail $file} r] $r
lappend res [catch {file tail $file} r] $r
cd ..
file delete -force tilde
cd $origdir
set res
} {0 1 {user "testNotExist" doesn't exist} ~testNotExist 0 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}
test filesystem-9.8 {path objects and glob and file tail and tilde} {
set res {}
set origdir [pwd]
cd [tcltest::temporaryDirectory]
file mkdir tilde
close [open tilde/~testNotExist w]
cd tilde
set file1 [lindex [glob *test*] 0]
set file2 "~testNotExist"
lappend res $file1 $file2
lappend res [catch {file tail $file1} r] $r
lappend res [catch {file tail $file2} r] $r
cd ..
file delete -force tilde
cd $origdir
set res
} {~testNotExist ~testNotExist 1 {user "testNotExist" doesn't exist} 1 {user "testNotExist" doesn't exist}}
test filesystem-9.9 {path objects and glob and file tail and tilde} {
set res {}
set origdir [pwd]
cd [tcltest::temporaryDirectory]
file mkdir tilde
close [open tilde/~testNotExist w]
cd tilde
set file1 [lindex [glob *test*] 0]
set file2 "~testNotExist"
lappend res [catch {file exists $file1} r] $r
lappend res [catch {file exists $file2} r] $r
lappend res [string equal $file1 $file2]
cd ..
file delete -force tilde
cd $origdir
set res
} {0 0 0 0 1}
cleanupTests
}
namespace delete ::tcl::test::fileSystem
return
|
Changes to tests/foreach.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: foreach, continue, break # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: foreach, continue, break
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: foreach.test,v 1.8.8.3 2007/03/13 16:26:33 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset a}
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 |
set x [expr $x + 1]
}
set x
} 13.0
# Check "continue".
| | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
set x [expr $x + 1]
}
set x
} 13.0
# Check "continue".
test foreach-5.1 {continue tests} {catch continue} 4
test foreach-5.2 {continue tests} {
set a {}
foreach i {a b c d} {
if {[string compare $i "b"] == 0} continue
set a [concat $a $i]
}
set a
} {a c d}
test foreach-5.3 {continue tests} {
set a {}
foreach i {a b c d} {
if {[string compare $i "b"] != 0} continue
set a [concat $a $i]
}
set a
} {b}
test foreach-5.4 {continue tests} {catch {continue foo} msg} 1
test foreach-5.5 {continue tests} {
catch {continue foo} msg
set msg
} {wrong # args: should be "continue"}
# Check "break".
test foreach-6.1 {break tests} {catch break} 3
test foreach-6.2 {break tests} {
set a {}
foreach i {a b c d} {
if {[string compare $i "c"] == 0} break
set a [concat $a $i]
}
set a
} {a b}
test foreach-6.3 {break tests} {catch {break foo} msg} 1
test foreach-6.4 {break tests} {
catch {break foo} msg
set msg
} {wrong # args: should be "break"}
# Check for bug #406709
test foreach-6.5 {break tests} {
proc a {} {
set a 1
foreach b b {list [concat a; break]; incr a}
incr a
}
a
} {2}
# Test for incorrect "double evaluation" semantics
test foreach-7.1 {delayed substitution of body} {
proc foo {} {
set a 0
foreach a [list 1 2 3] "
set x $a
"
set x
}
foo
} {0}
# [Bug 1671138]; infinite loop with empty var list in bytecompiled version
test foreach-9.1 {compiled empty var list} {
proc foo {} {
foreach {} x {
error "reached body"
}
}
list [catch { foo } msg] $msg
} {1 {foreach varlist is empty}}
test foreach-10.1 {foreach: [Bug 1671087]} -setup {
proc demo {} {
set vals {1 2 3 4}
trace add variable x write {string length $vals ;# }
foreach {x y} $vals {format $y}
}
} -body {
demo
} -cleanup {
rename demo {}
} -result {}
# cleanup
catch {unset a}
catch {unset x}
::tcltest::cleanupTests
return
|
Changes to tests/format.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: format # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1998 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: format
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1998 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: format.test,v 1.11.2.8 2005/10/13 21:45:32 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# The following code is needed because some versions of SCO Unix have
|
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
} {abcd This is a very long test string. % x x}
test format-2.5 {string formatting, embedded nulls} {
format "%10s" abc\0def
} " abc\0def"
test format-2.6 {string formatting, international chars} {
format "%10s" abc\ufeffdef
} " abc\ufeffdef"
| | | | | | | | | | | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
} {abcd This is a very long test string. % x x}
test format-2.5 {string formatting, embedded nulls} {
format "%10s" abc\0def
} " abc\0def"
test format-2.6 {string formatting, international chars} {
format "%10s" abc\ufeffdef
} " abc\ufeffdef"
test format-2.7 {string formatting, international chars} {
format "%.5s" abc\ufeffdef
} "abc\ufeffd"
test format-2.8 {string formatting, international chars} {
format "foo\ufeffbar%s" baz
} "foo\ufeffbarbaz"
test format-2.9 {string formatting, width} {
format "a%5sa" f
} "a fa"
test format-2.10 {string formatting, width} {
format "a%-5sa" f
} "af a"
test format-2.11 {string formatting, width} {
format "a%2sa" foo
} "afooa"
test format-2.12 {string formatting, width} {
format "a%0sa" foo
} "afooa"
test format-2.13 {string formatting, precision} {
format "a%.2sa" foobarbaz
} "afoa"
test format-2.14 {string formatting, precision} {
format "a%.sa" foobarbaz
} "aa"
test format-2.15 {string formatting, precision} {
list [catch {format "a%.-2sa" foobarbaz} msg] $msg
} {1 {bad field specifier "-"}}
test format-2.16 {string formatting, width and precision} {
format "a%5.2sa" foobarbaz
} "a foa"
test format-2.17 {string formatting, width and precision} {
format "a%5.7sa" foobarbaz
} "afoobarba"
test format-3.1 {Tcl_FormatObjCmd: character formatting} {
format "|%c|%0c|%-1c|%1c|%-6c|%6c|%*c|%*c|" 65 65 65 65 65 65 3 65 -4 65
} "|A|A|A|A|A | A| A|A |"
test format-3.2 {Tcl_FormatObjCmd: international character formatting} {
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
} -1
test format-10.2 {"h" format specifier} {nonPortable} {
format %hx 0x10fff
} fff
test format-10.3 {"h" format specifier} {nonPortable} {
format %hd 0x10000
} 0
test format-11.1 {XPG3 %$n specifiers} {
format {%2$d %1$d} 4 5
} {5 4}
test format-11.2 {XPG3 %$n specifiers} {
format {%2$d %1$d %1$d %3$d} 4 5 6
} {5 4 4 6}
| > > > > > > > > | 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
} -1
test format-10.2 {"h" format specifier} {nonPortable} {
format %hx 0x10fff
} fff
test format-10.3 {"h" format specifier} {nonPortable} {
format %hd 0x10000
} 0
test format-10.4 {"h" format specifier} {
# Bug 1154163: This is minimal behaviour for %hx specifier!
format %hx 1
} 1
test format-10.5 {"h" format specifier} {
# Bug 1284178: Highly out-of-range values shouldn't cause errors
format %hu 0x100000000
} 0
test format-11.1 {XPG3 %$n specifiers} {
format {%2$d %1$d} 4 5
} {5 4}
test format-11.2 {XPG3 %$n specifiers} {
format {%2$d %1$d %1$d %3$d} 4 5 6
} {5 4 4 6}
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 |
::tcltest::testConstraint 64bitInts \
[expr {0x80000000 > 0}]
::tcltest::testConstraint wideIntExpressions \
[expr {wide(0x80000000) != int(0x80000000)}]
test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} {
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
::tcltest::testConstraint 64bitInts \
[expr {0x80000000 > 0}]
::tcltest::testConstraint wideIntExpressions \
[expr {wide(0x80000000) != int(0x80000000)}]
test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} {
format %d 7810179016327718216
} 1819043144
test format-17.2 {testing %ld with wide} {64bitInts} {
format %ld 7810179016327718216
} 7810179016327718216
test format-17.3 {testing %ld with non-wide} {64bitInts} {
format %ld 42
} 42
test format-17.4 {testing %l with non-integer} {
format %lf 1
} 1.000000
test format-17.5 {type conversions with wides} {
set a 0xAAAAAAAA ;# NB: Careful to make separate objects here!
set b 0xAAAAAAA; append b A
set result [expr {$a == $b}]
format %x $a
lappend result [expr {$a == $b}]
} {1 1}
test format-18.1 {do not demote existing numeric values} {
set a 0xaaaaaaaa
# Ensure $a and $b are separate objects
set b 0xaaaa
append b aaaa
set result [expr {$a == $b}]
format %08lx $b
lappend result [expr {$a == $b}]
set b 0xaaaa
append b aaaa
lappend result [expr {$a == $b}]
format %08x $b
lappend result [expr {$a == $b}]
} {1 1 1 1}
test format-18.2 {do not demote existing numeric values} {wideIntExpressions} {
set a [expr {0xaaaaaaaaaa + 1}]
set b 0xaaaaaaaaab
list [format %08x $a] [expr {$a == $b}]
} {aaaaaaab 1}
test format-19.1 {
regression test - tcl-core message by Brian Griffin on
26 0ctober 2004
} -body {
set x 0x8fedc654
list [expr { ~ $x }] [format %08x [expr { ~$x }]]
} -match regexp -result {-2414724693 f*701239ab}
# cleanup
catch {unset a}
catch {unset b}
catch {unset c}
catch {unset d}
::tcltest::cleanupTests
return
|
Changes to tests/http.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# RCS: @(#) $Id: http.test,v 1.33.2.6 2006/10/06 19:00:53 hobbs Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[catch {package require http 2} version]} {
|
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
set port 8010
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}
# Ensure httpd file exists
| | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
set port 8010
set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
catch {unset data}
# Ensure httpd file exists
set origFile [file join [pwd] [file dirname [info script]] httpd]
set httpdFile [file join [temporaryDirectory] httpd_[pid]]
if {![file exists $httpdFile]} {
makeFile "" $httpdFile
file delete $httpdFile
file copy $origFile $httpdFile
set removeHttpd 1
}
|
| ︙ | ︙ | |||
78 79 80 81 82 83 84 |
unset port
return
} else {
set port [lindex [fconfigure $listen -sockname] 2]
}
}
| < | < < < | > > | < | | > > > > > > < < | | < | > | | | > < | < < < < < | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
unset port
return
} else {
set port [lindex [fconfigure $listen -sockname] 2]
}
}
test http-1.1 {http::config} {
http::config
} [list -accept */* -proxyfilter http::ProxyRequired -proxyhost {} -proxyport {} -urlencoding utf-8 -useragent "Tcl http client package $version"]
test http-1.2 {http::config} {
http::config -proxyfilter
} http::ProxyRequired
test http-1.3 {http::config} {
catch {http::config -junk}
} 1
test http-1.4 {http::config} {
set savedconf [http::config]
http::config -proxyhost nowhere.come -proxyport 8080 \
-proxyfilter myFilter -useragent "Tcl Test Suite" \
-urlencoding iso8859-1
set x [http::config]
eval http::config $savedconf
set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -urlencoding iso8859-1 -useragent {Tcl Test Suite}}
test http-1.5 {http::config} {
list [catch {http::config -proxyhost {} -junk 8080} msg] $msg
} {1 {Unknown option -junk, must be: -accept, -proxyfilter, -proxyhost, -proxyport, -urlencoding, -useragent}}
test http-1.6 {http::config} {
set enc [list [http::config -urlencoding]]
http::config -urlencoding iso8859-1
lappend enc [http::config -urlencoding]
http::config -urlencoding [lindex $enc 0]
set enc
} {utf-8 iso8859-1}
test http-2.1 {http::reset} {
catch {http::reset http#1}
} 0
test http-3.1 {http::geturl} {
list [catch {http::geturl -bogus flag} msg] $msg
} {1 {Unknown option flag, can be: -binary, -blocksize, -channel, -command, -handler, -headers, -progress, -query, -queryblocksize, -querychannel, -queryprogress, -validate, -timeout, -type}}
test http-3.2 {http::geturl} {
catch {http::geturl http:junk} err
set err
} {Unsupported URL: http:junk}
set url //[info hostname]:$port
set badurl //[info hostname]:6666
test http-3.3 {http::geturl} {
set token [http::geturl $url]
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET /</h2>
</body></html>"
set tail /a/b/c
set url //[info hostname]:$port/a/b/c
set fullurl http://user:pass@[info hostname]:$port/a/b/c
set binurl //[info hostname]:$port/binary
set posturl //[info hostname]:$port/post
set badposturl //[info hostname]:$port/droppost
set badcharurl //%user@[info hostname]:$port/a/^b/c
test http-3.4 {http::geturl} {
set token [http::geturl $url]
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
proc selfproxy {host} {
global port
return [list [info hostname] $port]
}
test http-3.5 {http::geturl} {
http::config -proxyfilter selfproxy
set token [http::geturl $url]
http::config -proxyfilter http::ProxyRequired
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET http:$url</h2>
</body></html>"
test http-3.6 {http::geturl} {
http::config -proxyfilter bogus
set token [http::geturl $url]
http::config -proxyfilter http::ProxyRequired
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
test http-3.7 {http::geturl} {
set token [http::geturl $url -headers {Pragma no-cache}]
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
test http-3.8 {http::geturl} {
set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 2000]
http::data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>POST $tail</h2>
<h2>Query</h2>
<dl>
<dt>Name<dd>Value
<dt>Foo<dd>Bar
</dl>
</body></html>"
test http-3.9 {http::geturl} {
set token [http::geturl $url -validate 1]
http::code $token
} "HTTP/1.0 200 OK"
test http-3.10 {http::geturl queryprogress} {
set query foo=bar
set sep ""
set i 0
# Create about 120K of query data
while {$i < 14} {
incr i
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 |
}
set postProgress {}
set t [http::geturl $posturl -query $query \
-queryprogress postProgress -queryblocksize 16384]
http::wait $t
list [http::status $t] [string length $query] $postProgress [http::data $t]
} {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
| < | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
}
set postProgress {}
set t [http::geturl $posturl -query $query \
-queryprogress postProgress -queryblocksize 16384]
http::wait $t
list [http::status $t] [string length $query] $postProgress [http::data $t]
} {ok 122879 {16384 32768 49152 65536 81920 98304 114688 122879} {Got 122879 bytes}}
test http-3.11 {http::geturl querychannel with -command} {
set query foo=bar
set sep ""
set i 0
# Create about 120K of query data
while {$i < 14} {
incr i
|
| ︙ | ︙ | |||
248 249 250 251 252 253 254 |
http::wait $t
close $fp
lappend testRes [http::status $t] $postResult
removeFile outdata
set testRes
} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
| < | | | < | | < | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
http::wait $t
close $fp
lappend testRes [http::status $t] $postResult
removeFile outdata
set testRes
} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}}
# On Linux platforms when the client and server are on the same host, the
# client is unable to read the server's response one it hits the write error.
# The status is "eof".
# On Windows, the http::wait procedure gets a "connection reset by peer" error
# while reading the reply.
test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} {
set query foo=bar
set sep ""
set i 0
# Create about 120K of query data
while {$i < 14} {
incr i
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
puts $errorInfo
error $err
}
removeFile outdata
list [http::status $t] [http::code $t]
} {ok {HTTP/1.0 200 Data follows}}
| < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < | < | < < | | < < | < < | | < < | | < < < | | | < < < < > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > | 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
puts $errorInfo
error $err
}
removeFile outdata
list [http::status $t] [http::code $t]
} {ok {HTTP/1.0 200 Data follows}}
test http-3.13 {http::geturl socket leak test} {
set chanCount [llength [file channels]]
for {set i 0} {$i < 3} {incr i} {
catch {http::geturl $badurl -timeout 5000}
}
# No extra channels should be taken
expr {[llength [file channels]] == $chanCount}
} 1
test http-3.14 "http::geturl $fullurl" {
set token [http::geturl $fullurl -validate 1]
http::code $token
} "HTTP/1.0 200 OK"
test http-3.15 {http::geturl parse failures} -body {
http::geturl "{invalid}:url"
} -returnCodes error -result {Unsupported URL: {invalid}:url}
test http-3.16 {http::geturl parse failures} -body {
http::geturl http:relative/url
} -returnCodes error -result {Unsupported URL: http:relative/url}
test http-3.17 {http::geturl parse failures} -body {
http::geturl /absolute/url
} -returnCodes error -result {Missing host part: /absolute/url}
test http-3.18 {http::geturl parse failures} -body {
http::geturl http://somewhere:123456789/
} -returnCodes error -result {Invalid port number: 123456789}
test http-3.19 {http::geturl parse failures} -body {
set ::http::strict 1
http::geturl http://{user}@somewhere
} -returnCodes error -result {Illegal characters in URL user}
test http-3.20 {http::geturl parse failures} -body {
set ::http::strict 1
http::geturl http://%user@somewhere
} -returnCodes error -result {Illegal encoding character usage "%us" in URL user}
test http-3.21 {http::geturl parse failures} -body {
set ::http::strict 1
http::geturl http://somewhere/{path}
} -returnCodes error -result {Illegal characters in URL path}
test http-3.22 {http::geturl parse failures} -body {
set ::http::strict 1
http::geturl http://somewhere/%path
} -returnCodes error -result {Illegal encoding character usage "%pa" in URL path}
test http-3.23 {http::geturl parse failures} -body {
set ::http::strict 1
http::geturl http://somewhere/path?{query}
} -returnCodes error -result {Illegal characters in URL path}
test http-3.24 {http::geturl parse failures} -body {
set ::http::strict 1
http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
test http-3.25 {http::geturl parse failures} -body {
set ::http::strict 0
set token [http::geturl $badcharurl]
http::cleanup $token
} -returnCodes ok -result {}
test http-4.1 {http::Event} {
set token [http::geturl $url]
upvar #0 $token data
array set meta $data(meta)
expr ($data(totalsize) == $meta(Content-Length))
} 1
test http-4.2 {http::Event} {
set token [http::geturl $url]
upvar #0 $token data
array set meta $data(meta)
string compare $data(type) [string trim $meta(Content-Type)]
} 0
test http-4.3 {http::Event} {
set token [http::geturl $url]
http::code $token
} {HTTP/1.0 200 Data follows}
test http-4.4 {http::Event} {
set testfile [makeFile "" testfile]
set out [open $testfile w]
set token [http::geturl $url -channel $out]
close $out
set in [open $testfile]
set x [read $in]
close $in
removeFile $testfile
set x
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
test http-4.5 {http::Event} {
set testfile [makeFile "" testfile]
set out [open $testfile w]
set token [http::geturl $url -channel $out]
close $out
upvar #0 $token data
removeFile $testfile
expr $data(currentsize) == $data(totalsize)
} 1
test http-4.6 {http::Event} {
set testfile [makeFile "" testfile]
set out [open $testfile w]
set token [http::geturl $binurl -channel $out]
close $out
set in [open $testfile]
fconfigure $in -translation binary
set x [read $in]
close $in
removeFile $testfile
set x
} "$bindata[string trimleft $binurl /]"
proc myProgress {token total current} {
global progress httpLog
if {[info exists httpLog] && $httpLog} {
puts "progress $total $current"
}
set progress [list $total $current]
}
if 0 {
# This test hangs on Windows95 because the client never gets EOF
set httpLog 1
test http-4.6.1 {http::Event} knownBug {
set token [http::geturl $url -blocksize 50 -progress myProgress]
set progress
} {111 111}
}
test http-4.7 {http::Event} {
set token [http::geturl $url -progress myProgress]
set progress
} {111 111}
test http-4.8 {http::Event} {
set token [http::geturl $url]
http::status $token
} {ok}
test http-4.9 {http::Event} {
set token [http::geturl $url -progress myProgress]
http::code $token
} {HTTP/1.0 200 Data follows}
test http-4.10 {http::Event} {
set token [http::geturl $url -progress myProgress]
http::size $token
} {111}
# Timeout cases
# Short timeout to working server (the test server). This lets us try a
# reset during the connection.
test http-4.11 {http::Event} {
set token [http::geturl $url -timeout 1 -command {#}]
http::reset $token
http::status $token
} {reset}
# Longer timeout with reset.
test http-4.12 {http::Event} {
set token [http::geturl $url/?timeout=10 -command {#}]
http::reset $token
http::status $token
} {reset}
# Medium timeout to working server that waits even longer. The timeout
# hits while waiting for a reply.
test http-4.13 {http::Event} {
set token [http::geturl $url?timeout=30 -timeout 10 -command {#}]
http::wait $token
http::status $token
} {timeout}
# Longer timeout to good host, bad port, gets an error after the
# connection "completes" but the socket is bad.
test http-4.14 {http::Event} {
set code [catch {
set token [http::geturl $badurl/?timeout=10 -timeout 10000 -command {#}]
if {[string length $token] == 0} {
error "bogus return from http::geturl"
}
http::wait $token
http::status $token
} err]
# error code varies among platforms.
list $code [regexp {(connect failed|couldn't open socket)} $err]
} {1 1}
# Bogus host
test http-4.15 {http::Event} {
# This test may fail if you use a proxy server. That is to be
# expected and is not a problem with Tcl.
set code [catch {
set token [http::geturl //not_a_host.tcl.tk -timeout 1000 -command {#}]
http::wait $token
http::status $token
} err]
# error code varies among platforms.
list $code [string match "couldn't open socket*" $err]
} {1 1}
test http-5.1 {http::formatQuery} {
http::formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value%20two}
# test http-5.2 obsoleted by 5.4 and 5.5 with http 2.5
test http-5.3 {http::formatQuery} {
http::formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}
test http-5.4 {http::formatQuery} {
http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=~bwelch&name2=%c2%a1%c2%a2%c2%a2}
test http-5.5 {http::formatQuery} {
set enc [http::config -urlencoding]
http::config -urlencoding iso8859-1
set res [http::formatQuery name1 ~bwelch name2 \xa1\xa2\xa2]
http::config -urlencoding $enc
set res
} {name1=~bwelch&name2=%a1%a2%a2}
test http-6.1 {http::ProxyRequired} {
http::config -proxyhost [info hostname] -proxyport $port
set token [http::geturl $url]
http::wait $token
http::config -proxyhost {} -proxyport {}
upvar #0 $token data
set data(body)
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET http:$url</h2>
</body></html>"
test http-7.1 {http::mapReply} {
http::mapReply "abc\$\[\]\"\\()\}\{"
} {abc%24%5b%5d%22%5c%28%29%7d%7b}
test http-7.2 {http::mapReply} {
# RFC 2718 specifies that we pass urlencoding on utf-8 chars by default,
# so make sure this gets converted to utf-8 then urlencoded.
http::mapReply "\u2208"
} {%e2%88%88}
test http-7.3 {http::formatQuery} {
set enc [http::config -urlencoding]
# this would be reverting to http <=2.4 behavior
http::config -urlencoding ""
set res [list [catch {http::mapReply "\u2208"} msg] $msg]
http::config -urlencoding $enc
set res
} [list 1 "can't read \"formMap(\u2208)\": no such element in array"]
test http-7.4 {http::formatQuery} {
set enc [http::config -urlencoding]
# this would be reverting to http <=2.4 behavior w/o errors
# (unknown chars become '?')
http::config -urlencoding "iso8859-1"
set res [http::mapReply "\u2208"]
http::config -urlencoding $enc
set res
} {%3f}
# cleanup
catch {unset url}
catch {unset badurl}
catch {unset port}
catch {unset data}
if {[info exists httpthread]} {
testthread send -async $httpthread {
testthread exit
}
} else {
close $listen
}
if {[info exists removeHttpd]} {
removeFile $httpdFile
}
rename bgerror {}
::tcltest::cleanupTests
|
Changes to tests/if-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: if-old.test,v 1.5.24.1 2003/03/27 13:11:12 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test if-old-1.1 {taking proper branch} {
|
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
set a
} {}
test if-old-1.5 {taking proper branch} {
set a {}
if 0 {set a 1} else {}
set a
} {}
| | | | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
set a
} {}
test if-old-1.5 {taking proper branch} {
set a {}
if 0 {set a 1} else {}
set a
} {}
test if-old-1.6 {taking proper branch} {
set a {}
if 0 {set a 1} elseif 1 {set a 2} elseif 1 {set a 3} else {set a 4}
set a
} {2}
test if-old-1.7 {taking proper branch} {
set a {}
if 0 {set a 1} elseif 0 {set a 2} elseif 1 {set a 3} else {set a 4}
set a
} {3}
test if-old-1.8 {taking proper branch} {
set a {}
if 0 {set a 1} elseif 0 {set a 2} elseif 0 {set a 3} else {set a 4}
set a
} {4}
test if-old-1.9 {taking proper branch, multiline test expr} {
set a {}
if {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {set a 3} else {set a 4}
set a
} {3}
|
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
test if-old-4.11 {error conditions} {
list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg
} {1 {error in else clause}}
# cleanup
::tcltest::cleanupTests
return
| < < < < < < < < < < < < | 158 159 160 161 162 163 164 |
test if-old-4.11 {error conditions} {
list [catch {if 0 then foo elseif 0 bar else {[error "error in else clause"]}} msg] $msg
} {1 {error in else clause}}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/incr-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: incr-old.test,v 1.6.2.1 2003/03/27 13:11:13 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset x}
test incr-old-1.1 {basic incr operation} {
set x 23
list [incr x] $x
} {24 24}
test incr-old-1.2 {basic incr operation} {
set x 106
list [incr x -5] $x
} {101 101}
test incr-old-1.3 {basic incr operation} {
set x " -106"
list [incr x 1] $x
} {-105 -105}
test incr-old-1.4 {basic incr operation} {
set x " +106"
list [incr x 1] $x
} {107 107}
test incr-old-2.1 {incr errors} {
list [catch incr msg] $msg
} {1 {wrong # args: should be "incr varName ?increment?"}}
|
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
set x {20 x}
list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "20 x"}}
# cleanup
::tcltest::cleanupTests
return
| < < < < < < < < < < < < | 90 91 92 93 94 95 96 |
set x {20 x}
list [catch {incr x 1} msg] $msg
} {1 {expected integer but got "20 x"}}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/indexObj.test.
1 2 3 4 5 6 7 8 9 10 | # This file is a Tcl script to test out the the procedures in file # tkIndexObj.c, which implement indexed table lookups. The tests here # are organized in the standard fashion for Tcl tests. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file is a Tcl script to test out the the procedures in file
# tkIndexObj.c, which implement indexed table lookups. The tests here
# are organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: indexObj.test,v 1.7.18.4 2006/04/06 18:57:30 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[info commands testindexobj] == {}} {
|
| ︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
} {5}
test indexObj-1.6 {forced exact match} {
testindexobj 1 0 xy abc def xalb xy alm
} {3}
test indexObj-1.7 {forced exact match} {
testindexobj 1 0 x abc def xalb xyz alm x
} {5}
test indexObj-2.1 {no match} {
list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg
} {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}}
test indexObj-2.2 {no match} {
list [catch {testindexobj 1 1 dddd abc} msg] $msg
} {1 {bad token "dddd": must be abc}}
test indexObj-2.3 {no match: no abbreviations} {
list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg
} {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}}
test indexObj-2.4 {ambiguous value} {
list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg
} {1 {ambiguous token "d": must be dumb, daughter, a, or c}}
test indexObj-2.5 {omit error message} {
list [catch {testindexobj 0 1 d x} msg] $msg
} {1 {}}
test indexObj-3.1 {cache result to skip next lookup} {
testindexobj check 42
} {42}
test indexObj-4.1 {free old internal representation} {
set x {a b}
| > > > > > > > > > > > > > > > > > > > > > > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
} {5}
test indexObj-1.6 {forced exact match} {
testindexobj 1 0 xy abc def xalb xy alm
} {3}
test indexObj-1.7 {forced exact match} {
testindexobj 1 0 x abc def xalb xyz alm x
} {5}
test indexObj-1.8 {exact match of empty values} {
testindexobj 1 1 {} a aa aaa {} b bb bbb
} 3
test indexObj-1.9 {exact match of empty values} {
testindexobj 1 0 {} a aa aaa {} b bb bbb
} 3
test indexObj-2.1 {no match} {
list [catch {testindexobj 1 1 dddd abc def xalb xyz alm x} msg] $msg
} {1 {bad token "dddd": must be abc, def, xalb, xyz, alm, or x}}
test indexObj-2.2 {no match} {
list [catch {testindexobj 1 1 dddd abc} msg] $msg
} {1 {bad token "dddd": must be abc}}
test indexObj-2.3 {no match: no abbreviations} {
list [catch {testindexobj 1 0 xy abc def xalb xyz alm} msg] $msg
} {1 {bad token "xy": must be abc, def, xalb, xyz, or alm}}
test indexObj-2.4 {ambiguous value} {
list [catch {testindexobj 1 1 d dumb daughter a c} msg] $msg
} {1 {ambiguous token "d": must be dumb, daughter, a, or c}}
test indexObj-2.5 {omit error message} {
list [catch {testindexobj 0 1 d x} msg] $msg
} {1 {}}
test indexObj-2.6 {TCL_EXACT => no "ambiguous" error message} {
list [catch {testindexobj 1 0 d dumb daughter a c} msg] $msg
} {1 {bad token "d": must be dumb, daughter, a, or c}}
test indexObj-2.7 {exact match of empty values} {
list [catch {testindexobj 1 1 {} a b c} msg] $msg
} {1 {ambiguous token "": must be a, b, or c}}
test indexObj-2.8 {exact match of empty values: singleton case} {
list [catch {testindexobj 1 0 {} a} msg] $msg
} {1 {bad token "": must be a}}
test indexObj-2.9 {non-exact match of empty values: singleton case} {
# NOTE this is a special case. Although the empty string is a
# unique prefix, we have an established history of rejecting
# empty lookup keys, requiring any unique prefix match to have
# at least one character.
list [catch {testindexobj 1 1 {} a} msg] $msg
} {1 {bad token "": must be a}}
test indexObj-3.1 {cache result to skip next lookup} {
testindexobj check 42
} {42}
test indexObj-4.1 {free old internal representation} {
set x {a b}
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
testgetindexfromobjstruct $x 1
testgetindexfromobjstruct $x 1
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
# cleanup
::tcltest::cleanupTests
return
| < < < < < < < < < < < < | 129 130 131 132 133 134 135 |
testgetindexfromobjstruct $x 1
testgetindexfromobjstruct $x 1
} "wrong # args: should be \"testgetindexfromobjstruct c 1\""
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/info.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: info # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | > > | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
# -*- tcl -*-
# Commands covered: info
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2006 ActiveState
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: info.test,v 1.24.2.5 2006/11/28 22:20:02 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Set up namespaces needed to test operation of "info args", "info body",
# "info default", and "info procs" with imported procedures.
catch {namespace delete test_ns_info1 test_ns_info2}
namespace eval test_ns_info1 {
namespace export *
proc p {x} {return "x=$x"}
proc q {{y 27} {z {}}} {return "y=$y"}
}
testConstraint tip280 [info exists tcl_platform(tip,280)]
testConstraint !tip280 [expr {![info exists tcl_platform(tip,280)]}]
test info-1.1 {info args option} {
proc t1 {a bbb c} {return foo}
info args t1
} {a bbb c}
test info-1.2 {info args option} {
proc t1 {{a default1} {bbb default2} {c default3} args} {return foo}
|
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
test info-5.1 {info complete option} {
list [catch {info complete} msg] $msg
} {1 {wrong # args: should be "info complete command"}}
test info-5.2 {info complete option} {
info complete abc
} 1
| | | | | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
test info-5.1 {info complete option} {
list [catch {info complete} msg] $msg
} {1 {wrong # args: should be "info complete command"}}
test info-5.2 {info complete option} {
info complete abc
} 1
test info-5.3 {info complete option} {
info complete "\{abcd "
} 0
test info-5.4 {info complete option} {
info complete {# Comment should be complete command}
} 1
test info-5.5 {info complete option} {
info complete {[a [b] }
} 0
test info-5.6 {info complete option} {
info complete {[a [b]}
} 0
test info-6.1 {info default option} {
proc t1 {a b {c d} {e "long default value"}} {}
info default t1 a value
} 0
|
| ︙ | ︙ | |||
287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
set _xxx1 1
set _xxx2 2
lsort [info g _xxx*]
} {_xxx1 _xxx2}
test info-8.3 {info globals option} {
list [catch {info globals 1 2} msg] $msg
} {1 {wrong # args: should be "info globals ?pattern?"}}
test info-9.1 {info level option} {
info level
} 0
test info-9.2 {info level option} {
proc t1 {a b} {
set x [info le]
| > > > > > > > > > > > > > > > > > | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
set _xxx1 1
set _xxx2 2
lsort [info g _xxx*]
} {_xxx1 _xxx2}
test info-8.3 {info globals option} {
list [catch {info globals 1 2} msg] $msg
} {1 {wrong # args: should be "info globals ?pattern?"}}
test info-8.4 {info globals option: may have leading namespace qualifiers} {
set x 0
list [info globals x] [info globals :x] [info globals ::x] [info globals :::x] [info globals ::::x]
} {x {} x x x}
test info-8.5 {info globals option: only return existing global variables} {
-setup {
catch {unset ::NO_SUCH_VAR}
proc evalInProc script {eval $script}
}
-body {
evalInProc {global NO_SUCH_VAR; info globals NO_SUCH_VAR}
}
-cleanup {
rename evalInProc {}
}
-result {}
}
test info-9.1 {info level option} {
info level
} 0
test info-9.2 {info level option} {
proc t1 {a b} {
set x [info le]
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
test info-19.5 {info vars with temporary variables} {
proc t1 {} {
foreach a {b c} {}
info vars
}
t1
} {a}
# Check whether the extra testing functions are defined...
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
} else {
set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
}
| > > > > > > > > | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
test info-19.5 {info vars with temporary variables} {
proc t1 {} {
foreach a {b c} {}
info vars
}
t1
} {a}
test info-19.6 {info vars: Bug 1072654} -setup {
namespace eval :: unset -nocomplain foo
catch {namespace delete x}
} -body {
namespace eval x info vars foo
} -cleanup {
namespace delete x
} -result {}
# Check whether the extra testing functions are defined...
if {([catch {expr T1()} msg] == 1) && ($msg == {unknown math function "T1"})} {
set functions {abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
} else {
set functions {T1 T2 T3 abs acos asin atan atan2 ceil cos cosh double exp floor fmod hypot int log log10 pow rand round sin sinh sqrt srand tan tanh wide}
}
|
| ︙ | ︙ | |||
622 623 624 625 626 627 628 |
test info-20.5 {info functions option} {
list [catch {info functions raise an error} msg] $msg
} {1 {wrong # args: should be "info functions ?pattern?"}}
test info-21.1 {miscellaneous error conditions} {
list [catch {info} msg] $msg
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
| | > > > | > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 |
test info-20.5 {info functions option} {
list [catch {info functions raise an error} msg] $msg
} {1 {wrong # args: should be "info functions ?pattern?"}}
test info-21.1 {miscellaneous error conditions} {
list [catch {info} msg] $msg
} {1 {wrong # args: should be "info option ?arg arg ...?"}}
test info-21.2 {miscellaneous error conditions} !tip280 {
list [catch {info gorp} msg] $msg
} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.2-280 {miscellaneous error conditions} tip280 {
list [catch {info gorp} msg] $msg
} {1 {bad option "gorp": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3 {miscellaneous error conditions} !tip280 {
list [catch {info c} msg] $msg
} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.3-280 {miscellaneous error conditions} tip280 {
list [catch {info c} msg] $msg
} {1 {ambiguous option "c": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4 {miscellaneous error conditions} !tip280 {
list [catch {info l} msg] $msg
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.4-280 {miscellaneous error conditions} tip280 {
list [catch {info l} msg] $msg
} {1 {ambiguous option "l": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5 {miscellaneous error conditions} !tip280 {
list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
test info-21.5-280 {miscellaneous error conditions} tip280 {
list [catch {info s} msg] $msg
} {1 {ambiguous option "s": must be args, body, cmdcount, commands, complete, default, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, patchlevel, procs, script, sharedlibextension, tclversion, or vars}}
##
# ### ### ### ######### ######### #########
## info frame
## Helper
# For the more complex results we cut the file name down to remove
# path dependencies, and we use only part of the first line of the
# reported command. The latter is required because otherwise the whole
# test case may appear in some results, but the result is part of the
# testcase. An infinite string would be required to describe that. The
# cutting-down breaks this.
proc reduce {frame} {
set pos [lsearch -exact $frame cmd]
incr pos
set cmd [lindex $frame $pos]
if {[regexp \n $cmd]} {
set first [string range [lindex [split $cmd \n] 0] 0 end-11]
set frame [lreplace $frame $pos $pos $first]
}
set pos [lsearch -exact $frame file]
if {$pos >=0} {
incr pos
set tail [file tail [lindex $frame $pos]]
set frame [lreplace $frame $pos $pos $tail]
}
set frame
}
## Helper
# Generate a stacktrace from the current location to top. This code
# not only depends on the exact location of things, but also on the
# implementation of tcltest. Any changes and these tests will have to
# be updated.
proc etrace {} {
set res {}
set level [info frame]
while {$level} {
lappend res [list $level [reduce [info frame $level]]]
incr level -1
}
return $res
}
##
test info-22.0 {info frame, levels} tip280 {
info frame
} 7
test info-22.1 {info frame, bad level relative} tip280 {
# catch is another level!, i.e. we have 8, not 7
catch {info frame -8} msg
set msg
} {bad level "-8"}
test info-22.2 {info frame, bad level absolute} tip280 {
# catch is another level!, i.e. we have 8, not 7
catch {info frame 9} msg
set msg
} {bad level "9"}
test info-22.3 {info frame, current, relative} tip280 {
info frame 0
} {type eval line 2 cmd {info frame 0}}
test info-22.4 {info frame, current, relative, nested} tip280 {
set res [info frame 0]
} {type eval line 2 cmd {info frame 0}}
test info-22.5 {info frame, current, absolute} tip280 {
reduce [info frame 7]
} {type eval line 2 cmd {info frame 7}}
test info-22.6 {info frame, global, relative} tip280 {
reduce [info frame -6]
} {type source line 759 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relativ}
test info-22.7 {info frame, global, absolute} tip280 {
reduce [info frame 1]
} {type source line 763 file info.test cmd test\ info-22.7\ \{info\ frame,\ global,\ absolut}
test info-22.8 {info frame, basic trace} tip280 {
join [etrace] \n
} {8 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
7 {type eval line 2 cmd etrace}
6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
5 {type eval line 1 cmd {::tcltest::RunTest }}
4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ }
2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
1 {type source line 767 file info.test cmd test\ info-22.8\ \{info\ frame,\ basic\ trac}}
## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
test info-23.0 {eval'd info frame} tip280 {
eval {info frame}
} 8
test info-23.1 {eval'd info frame, semi-dynamic} tip280 {
eval info frame
} 8
test info-23.2 {eval'd info frame, dynamic} tip280 {
set script {info frame}
eval $script
} 8
test info-23.3 {eval'd info frame, literal} tip280 {
eval {
info frame 0
}
} {type eval line 2 cmd {info frame 0}}
test info-23.4 {eval'd info frame, semi-dynamic} tip280 {
eval info frame 0
} {type eval line 1 cmd {info frame 0}}
test info-23.5 {eval'd info frame, dynamic} tip280 {
set script {info frame 0}
eval $script
} {type eval line 1 cmd {info frame 0}}
test info-23.6 {eval'd info frame, trace} tip280 {
set script {etrace}
join [eval $script] \n
} {9 {type source line 723 file info.test cmd {info frame $level} proc ::etrace level 0}
8 {type eval line 1 cmd etrace}
7 {type eval line 3 cmd {eval $script}}
6 {type source line 2277 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}
5 {type eval line 1 cmd {::tcltest::RunTest }}
4 {type source line 1619 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::Eval}
3 {type eval line 1 cmd ::tcltest::Eval\ \{::tcltest::RunTest\ }
2 {type source line 1966 file tcltest.tcl cmd {uplevel 1 [list [namespace origin Eval] $command 1]} proc ::tcltest::test}
1 {type source line 806 file info.test cmd test\ info-23.6\ \{eval'd\ info\ frame,\ trac}}
## The line 1966 is off by 5 from the true value of 1971. This is a knownBug, see testcase 30.0
# -------------------------------------------------------------------------
# Procedures defined in scripts which are arguments to control
# structures (like 'namespace eval', 'interp eval', 'if', 'while',
# 'switch', 'catch', 'for', 'foreach', etc.) have no absolute
# location. The command implementations execute such scripts through
# Tcl_EvalObjEx. Flag 0 causes it to use the bytecode compiler. This
# causes the connection to the context to be lost. Currently only
# procedure bodies are able to remember their context.
# -------------------------------------------------------------------------
namespace eval foo {
proc bar {} {info frame 0}
}
test info-24.0 {info frame, interaction, namespace eval} tip280 {
reduce [foo::bar]
} {type source line 832 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
set flag 1
if {$flag} {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
}
test info-24.1 {info frame, interaction, if} tip280 {
reduce [foo::bar]
} {type source line 846 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
set flag 1
while {$flag} {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
set flag 0
}
test info-24.2 {info frame, interaction, while} tip280 {
reduce [foo::bar]
} {type source line 860 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
catch {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
}
test info-24.3 {info frame, interaction, catch} tip280 {
reduce [foo::bar]
} {type source line 874 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
foreach var val {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
break
}
test info-24.4 {info frame, interaction, foreach} tip280 {
reduce [foo::bar]
} {type source line 887 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
for {} {1} {} {
namespace eval foo {}
proc ::foo::bar {} {info frame 0}
break
}
test info-24.5 {info frame, interaction, for} tip280 {
reduce [foo::bar]
} {type source line 901 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
eval {
proc bar {} {info frame 0}
}
test info-25.0 {info frame, proc in eval} tip280 {
reduce [bar]
} {type source line 914 file info.test cmd {info frame 0} proc ::bar level 0}
proc bar {} {info frame 0}
test info-25.1 {info frame, regular proc} tip280 {
reduce [bar]
} {type source line 921 file info.test cmd {info frame 0} proc ::bar level 0}
rename bar {}
test info-30.0 {bs+nl in literal words} {tip280 knownBug} {
if {1} {
set res \
[reduce [info frame 0]]
}
set res
# This is reporting line 3 instead of the correct 4 because the
# bs+nl combination is subst by the parser before the 'if'
# command, and the the bcc sees the word. To fix record the
# offsets of all bs+nl sequences in literal words, then use the
# information in the bcc to bump line numbers when parsing over
# the location. Also affected: testcases 22.8 and 23.6.
} {type eval line 4 cmd {info frame 0} proc ::tcltest::RunTest}
# -------------------------------------------------------------------------
# See 24.0 - 24.5 for similar situations, using literal scripts.
set body {set flag 0
set a c
set res [info frame 0]} ;# line 3!
test info-31.0 {ns eval, script in variable} tip280 {
namespace eval foo $body
set res
} {type eval line 3 cmd {info frame 0} level 0}
catch {namespace delete foo}
test info-31.1 {if, script in variable} tip280 {
if 1 $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
test info-31.1a {if, script in variable} tip280 {
if 1 then $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
test info-31.2 {while, script in variable} tip280 {
set flag 1
while {$flag} $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
# .3 - proc - scoping prevent return of result ...
test info-31.4 {foreach, script in variable} tip280 {
foreach var val $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
test info-31.5 {for, script in variable} tip280 {
set flag 1
for {} {$flag} {} $body
set res
} {type eval line 3 cmd {info frame 0} proc ::tcltest::RunTest}
test info-31.6 {eval, script in variable} tip280 {
eval $body
set res
} {type eval line 3 cmd {info frame 0}}
# -------------------------------------------------------------------------
namespace eval foo {}
set x foo
switch -exact -- $x {
foo {
proc ::foo::bar {} {info frame 0}
}
}
test info-24.6.0 {info frame, interaction, switch, list body} tip280 {
reduce [foo::bar]
} {type source line 1001 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
unset x
# -------------------------------------------------------------------------
namespace eval foo {}
set x foo
switch -exact -- $x foo {
proc ::foo::bar {} {info frame 0}
}
test info-24.6.1 {info frame, interaction, switch, multi-body} tip280 {
reduce [foo::bar]
} {type source line 1017 file info.test cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
unset x
# -------------------------------------------------------------------------
namespace eval foo {}
set x foo
switch -exact -- $x [list foo {
proc ::foo::bar {} {info frame 0}
}]
test info-24.6.2 {info frame, interaction, switch, list body, dynamic} tip280 {
reduce [foo::bar]
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
unset x
# -------------------------------------------------------------------------
set body {
foo {
proc ::foo::bar {} {info frame 0}
}
}
namespace eval foo {}
set x foo
switch -exact -- $x $body
test info-31.7 {info frame, interaction, switch, dynamic} tip280 {
reduce [foo::bar]
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
unset x
# -------------------------------------------------------------------------
set body {
proc ::foo::bar {} {info frame 0}
}
namespace eval foo {}
eval $body
test info-32.0 {info frame, dynamic procedure} tip280 {
reduce [foo::bar]
} {type proc line 1 cmd {info frame 0} proc ::foo::bar level 0}
namespace delete foo
# -------------------------------------------------------------------------
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}
::tcltest::cleanupTests
return
|
Changes to tests/init.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Functionality covered: this file contains a collection of tests for the # auto loading and namespaces. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Functionality covered: this file contains a collection of tests for the
# auto loading and namespaces.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: init.test,v 1.9.2.2 2004/10/26 20:14:36 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
|
| ︙ | ︙ | |||
63 64 65 66 67 68 69 |
set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list package require tcltest]
interp eval $testInterp [list namespace import -force ::tcltest::*]
interp eval $testInterp {
| < < < < | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
set testInterp [interp create]
interp eval $testInterp [list set argv $argv]
interp eval $testInterp [list package require tcltest]
interp eval $testInterp [list namespace import -force ::tcltest::*]
interp eval $testInterp {
auto_reset
catch {rename parray {}}
test init-2.0 {load parray - stage 1} {
set ret [catch {parray} error]
rename parray {} ; # remove it, for the next test - that should not fail.
list $ret $error
|
| ︙ | ︙ | |||
125 126 127 128 129 130 131 |
test init-2.7 {oad setLogCmd from safe:: - stage 2} {
namespace eval safe setLogCmd
rename ::safe::setLogCmd {} ; # should not fail
} {}
| > > | < | | < | | | < | | > | | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
test init-2.7 {oad setLogCmd from safe:: - stage 2} {
namespace eval safe setLogCmd
rename ::safe::setLogCmd {} ; # should not fail
} {}
test init-2.8 {load tcl::HistAdd} -setup {
auto_reset
catch {rename ::tcl::HistAdd {}}
} -body {
# 3 ':' on purpose
list [catch {tcl:::HistAdd} error] $error
} -cleanup {
rename ::tcl::HistAdd {} ;
} -result {1 {wrong # args: should be "tcl:::HistAdd command ?exec?"}}
test init-3.0 {random stuff in the auto_index, should still work} {
set auto_index(foo:::bar::blah) {
namespace eval foo {namespace eval bar {proc blah {} {return 1}}}
}
foo:::bar::blah
} 1
# Tests that compare the error stack trace generated when autoloading
# with that generated when no autoloading is necessary. Ideally they
# should be the same.
set count 0
foreach arg [subst -nocommands -novariables {
c
{argument
which spans
multiple lines}
{argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack}
{argument which spans multiple lines
and is long enough to be truncated and
" <- includes a false lead in the prune point search
and must be longer still to force truncation}
{contrived example: rare circumstance
where the point at which to prune the
error stack cannot be uniquely determined.
foo bar foo
"}
{contrived example: rare circumstance
where the point at which to prune the
error stack cannot be uniquely determined.
foo bar
"}
{argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library}
}] {
test init-4.$count.0 {::errorInfo produced by [unknown]} {
auto_reset
catch {parray a b $arg}
set first $::errorInfo
catch {parray a b $arg}
set second $::errorInfo
|
| ︙ | ︙ | |||
196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
set second $::errorInfo
string equal $first $second
} 1
incr count
}
} ;# End of [interp eval $testInterp]
# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return
| > | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
set second $::errorInfo
string equal $first $second
} 1
incr count
}
cleanupTests
} ;# End of [interp eval $testInterp]
# cleanup
interp delete $testInterp
::tcltest::cleanupTests
return
|
Changes to tests/interp.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the multiple interpreter facility of Tcl # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# This file tests the multiple interpreter facility of Tcl
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: interp.test,v 1.19.2.6 2004/10/28 00:01:07 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
# The set of hidden commands is platform dependent:
if {"$tcl_platform(platform)" == "macintosh"} {
set hidden_cmds {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source}
|
| ︙ | ︙ | |||
114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
proc interp$thenum {} {}
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr $anothernum - $thenum
} 1
foreach i [interp slaves] {
interp delete $i
}
# Part 2: Testing "interp slaves" and "interp exists"
test interp-3.1 {testing interp exists and interp slaves} {
| > > > | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
proc interp$thenum {} {}
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy anothernum
expr $anothernum - $thenum
} 1
test interp-2.13 {correct default when no $path arg is given} -body {
interp create --
} -match regexp -result {interp[0-9]+}
foreach i [interp slaves] {
interp delete $i
}
# Part 2: Testing "interp slaves" and "interp exists"
test interp-3.1 {testing interp exists and interp slaves} {
|
| ︙ | ︙ | |||
292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
proc nonexistent-command-in-master {} {return i_exist!}
a eval zop
} i_exist!
test interp-9.3 {testing aliases for hidden commands} {
catch {interp create a}
a eval {proc p {} {return ENTER_A}}
interp alias {} p a p
lappend res [list [catch p msg] $msg]
interp hide a p
lappend res [list [catch p msg] $msg]
rename p {}
interp delete a
set res
} {{0 ENTER_A} {1 {invalid command name "p"}}}
| > | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
proc nonexistent-command-in-master {} {return i_exist!}
a eval zop
} i_exist!
test interp-9.3 {testing aliases for hidden commands} {
catch {interp create a}
a eval {proc p {} {return ENTER_A}}
interp alias {} p a p
set res {}
lappend res [list [catch p msg] $msg]
interp hide a p
lappend res [list [catch p msg] $msg]
rename p {}
interp delete a
set res
} {{0 ENTER_A} {1 {invalid command name "p"}}}
|
| ︙ | ︙ | |||
752 753 754 755 756 757 758 759 760 761 762 763 764 765 |
}
}
interp alias {a b} dela {} dela
proc dela {} {interp delete a}
list [catch {a eval foo} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
}
# Test alias deletion
test interp-19.1 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
| > > > > > > > > > > | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
}
}
interp alias {a b} dela {} dela
proc dela {} {interp delete a}
list [catch {a eval foo} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
}
test interp-18.9 {eval in deleted interp, bug 495830} {knownBug} {
interp create tst
interp alias tst suicide {} interp delete tst
list [catch {tst eval {suicide; set a 5}} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
test interp-18.10 {eval in deleted interp, bug 495830} {
interp create tst
interp alias tst suicide {} interp delete tst
list [catch {tst eval {set set set; suicide; $set a 5}} msg] $msg
} {1 {attempt to call eval in deleted interpreter}}
# Test alias deletion
test interp-19.1 {alias deletion} {
catch {interp delete a}
interp create a
interp alias a foo a bar
|
| ︙ | ︙ | |||
1491 1492 1493 1494 1495 1496 1497 |
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x} msg] $msg]
interp delete a
set l
| | | | | 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 |
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.46 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x x} msg] $msg]
interp delete a
set l
} {1 {can only hide global namespace commands (use rename then hide)}}
test interp-20.47 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
proc x {} {}
}
set l [list [catch {interp hide a x foo::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-20.48 {interp hide vs namespaces} {
catch {interp delete a}
interp create a
a eval {
namespace eval foo {}
proc foo::x {} {}
}
set l [list [catch {interp hide a foo::x bar::x} msg] $msg]
interp delete a
set l
} {1 {cannot use namespace qualifiers in hidden command token (rename)}}
test interp-21.1 {interp hidden} {
interp hidden {}
} ""
test interp-21.2 {interp hidden} {
interp hidden
} ""
|
| ︙ | ︙ | |||
2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 |
cd ..
file delete cwd_test
interp delete $i
cd [workingDirectory]
expr {[string equal $parent $child] ? 1 :
"\{$parent\} != \{$child\}"}
} 1
# cleanup
foreach i [interp slaves] {
interp delete $i
}
::tcltest::cleanupTests
return
| > > > > > > > > > > | 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 |
cd ..
file delete cwd_test
interp delete $i
cd [workingDirectory]
expr {[string equal $parent $child] ? 1 :
"\{$parent\} != \{$child\}"}
} 1
test interp-33.1 {refCounting for target words of alias [Bug 730244]} {
# This test will panic if Bug 730244 is not fixed.
set i [interp create]
proc testHelper args {rename testHelper {}; return $args}
# Note: interp names are simple words by default
trace add execution testHelper enter "interp alias $i alias {} ;#"
interp alias $i alias {} testHelper this
$i eval alias
} this
# cleanup
foreach i [interp slaves] {
interp delete $i
}
::tcltest::cleanupTests
return
|
Changes to tests/io.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # Functionality covered: operation of all IO commands, and all procedures # defined in generic/tclIO.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | > | > > > < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
# -*- tcl -*-
# Functionality covered: operation of all IO commands, and all procedures
# defined in generic/tclIO.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: io.test,v 1.40.2.12 2007/02/12 19:25:42 andreas_kupries Exp $
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
namespace eval ::tcl::test::io {
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::interpreter
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::test
namespace import ::tcltest::testConstraint
namespace import ::tcltest::viewFile
testConstraint testchannel [llength [info commands testchannel]]
testConstraint exec [llength [info commands exec]]
testConstraint openpipe 1
testConstraint fileevent [llength [info commands fileevent]]
testConstraint fcopy [llength [info commands fcopy]]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0
# set up a long data file for some of the following tests
set path(longfile) [makeFile {} longfile]
set f [open $path(longfile) w]
fconfigure $f -eofchar {} -translation lf
for { set i 0 } { $i < 100 } { incr i} {
puts $f "#123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef0123456789abcdef
|
| ︙ | ︙ | |||
111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp
puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
close $f
contents $path(test2)
} " \x1b\$B\$O\x1b(B"
test io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp
puts -nonewline $f [format %s%c [string repeat " " 4] 12399]
close $f
contents $path(test2)
} " \x1b\$B\$O\x1b(B"
test io-1.9 {Tcl_WriteChars: WriteChars} {
# When closing a channel with an encoding that appends
# escape bytes, check for the case where the escape
# bytes overflow the current IO buffer. The bytes
# should be moved into a new buffer.
set data "1234567890 [format %c 12399]"
set sizes [list]
# With default buffer size
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size equal to the length
# of the data, the escape bytes would
# go into the next buffer.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 16
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size that is large enough
# to hold 1 byte of escaped data, but
# not all 3. This should not write
# the escape bytes to the first buffer
# and then again to the second buffer.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 17
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size that can hold 2 out of
# 3 bytes of escaped data.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 18
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
# With buffer size that can hold all the
# data and escape bytes.
set f [open $path(test2) w]
fconfigure $f -encoding iso2022-jp -buffersize 19
puts -nonewline $f $data
close $f
lappend sizes [file size $path(test2)]
set sizes
} {19 19 19 19 19}
test io-2.1 {WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
|
| ︙ | ︙ | |||
403 404 405 406 407 408 409 |
puts $f hi
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line]
close $f
set x
} [list 256 $a]
| | | | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 |
puts $f hi
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line]
close $f
set x
} [list 256 $a]
test io-6.7 {Tcl_GetsObj: error in input} {stdio openpipe} {
# if (FilterInputBytes(chanPtr, &gs) != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
puts -nonewline $f "hi\nwould"
flush $f
gets $f
fconfigure $f -blocking 0
set x [gets $f line]
close $f
set x
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 15]
| | | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 15]
test io-6.31 {Tcl_GetsObj: crlf mode: buffer exhausted, blocked} {stdio testchannel openpipe fileevent} {
# (FilterInputBytes() != 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {crlf lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbb\r\n123456789012345\r"
fconfigure $f -buffersize 16
set x [gets $f]
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 |
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
close $f
set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
| | | | | | 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 |
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
lappend x [gets $f line] $line [gets $f line] $line [gets $f line] $line
close $f
set x
} [list 4 "abcd" 4 "efgh" 4 "ijkl" 4 "mnop" -1 ""]
test io-6.43 {Tcl_GetsObj: input saw cr} {stdio testchannel openpipe fileevent} {
# if (chanPtr->flags & INPUT_SAW_CR)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.44 {Tcl_GetsObj: input saw cr, not followed by cr} {stdio testchannel openpipe fileevent} {
# not (*eol == '\n')
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
set x [list [gets $f]]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [testchannel queuedcr $f]
fconfigure $f -blocking 1
puts -nonewline $f "abcd\refg\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
lappend x [gets $f line] $line
close $f
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} {
# Tcl_ExternalToUtf()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
fconfigure $f -encoding unicode
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg"
lappend x [gets $f line] $line [testchannel queuedcr $f]
close $f
set x
} [list 15 "123456789abcdef" 1 4 "abcd" 0]
test io-6.46 {Tcl_GetsObj: input saw cr, followed by just \n should give eof} {stdio testchannel openpipe fileevent} {
# memmove()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
| | | 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
close $f
set f [open $path(test1)]
fconfigure $f -encoding iso2022-jp
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 8 "there\u4e00ok" 11 "\u4e01more bytes" 4 "here"]
test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio openpipe fileevent} {
update
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -buffering none
puts -nonewline $f "foobar"
fconfigure $f -blocking 0
variable x {}
after 500 [namespace code { lappend x timeout }]
|
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 |
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
| | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
lappend x [tell $f] [testchannel inputbuffered $f] [eof $f]
lappend x [gets $f line] $line
close $f
set x
} [list 15 "1234567890123\uff10\uff11" 18 0 1 -1 ""]
test io-7.4 {FilterInputBytes: recover from split up character} {stdio openpipe fileevent} {
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none
puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
fconfigure $f -encoding shiftjis -blocking 0
fileevent $f read [namespace code "ready $f"]
variable x {}
proc ready {f} {
|
| ︙ | ︙ | |||
1075 1076 1077 1078 1079 1080 1081 |
fconfigure $f -encoding ascii -translation auto -buffersize 16
# here
gets $f
set x [testchannel inputbuffered $f]
close $f
set x
} "7"
| | | | 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 |
fconfigure $f -encoding ascii -translation auto -buffersize 16
# here
gets $f
set x [testchannel inputbuffered $f]
close $f
set x
} "7"
test io-8.2 {PeekAhead: only go to device if no more cached data} {stdio testchannel openpipe fileevent} {
# not (bufPtr->nextPtr == NULL)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation lf -encoding ascii -buffering none
puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
variable x {}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [gets $f line] $line [testchannel inputbuffered $f]
}
fconfigure $f -encoding unicode -buffersize 16 -blocking 0
vwait [namespace which -variable x]
fconfigure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 42 15 "123456789012345" 25]
test io-8.3 {PeekAhead: no cached data available} {stdio testchannel openpipe fileevent} {
# (bytesLeft == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
set x [list [gets $f line] $line [testchannel queuedcr $f]]
|
| ︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 |
# that cached data is available in buffer w/o having to call driver.
set x [gets $f]
close $f
set x
} $a
unset a
| | | | | 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 |
# that cached data is available in buffer w/o having to call driver.
set x [gets $f]
close $f
set x
} $a
unset a
test io-8.5 {PeekAhead: don't peek if last read was short} {stdio testchannel openpipe fileevent} {
# (bufPtr->nextAdded < bufPtr->length)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary}
puts -nonewline $f "abcdefghijklmno\r"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.6 {PeekAhead: change to non-blocking mode} {stdio testchannel openpipe fileevent} {
# ((chanPtr->flags & CHANNEL_NONBLOCKING) == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffersize 16
puts -nonewline $f "abcdefghijklmno\r"
flush $f
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
close $f
set x
} {15 abcdefghijklmno 1}
test io-8.7 {PeekAhead: cleanup} {stdio testchannel openpipe fileevent} {
# Make sure bytes are removed from buffer.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto binary} -buffering none
puts -nonewline $f "abcdefghijklmno\r"
# here
set x [list [gets $f line] $line [testchannel queuedcr $f]]
|
| ︙ | ︙ | |||
1318 1319 1320 1321 1322 1323 1324 |
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
| | | 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 |
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} {
# (srcRead == 0)
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -encoding binary -buffering none -buffersize 16
puts -nonewline $f "123456789012345\x96"
fconfigure $f -encoding shiftjis -blocking 0
|
| ︙ | ︙ | |||
1343 1344 1345 1346 1347 1348 1349 |
puts -nonewline $f "\x7b"
after 500 ;# Give the cat process time to catch up
fconfigure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
close $f
set x
} [list "123456789012345" 1 "\u672c" 0]
| | | 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 |
puts -nonewline $f "\x7b"
after 500 ;# Give the cat process time to catch up
fconfigure $f -encoding shiftjis -blocking 0
vwait [namespace which -variable x]
close $f
set x
} [list "123456789012345" 1 "\u672c" 0]
test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} {
set path(test1) [makeFile {
fconfigure stdout -encoding binary -buffering none
gets stdin; puts -nonewline "\xe7"
gets stdin; puts -nonewline "\x89"
gets stdin; puts -nonewline "\xa6"
} test1]
set f [open "|[list [interpreter] $path(test1)]" r+]
|
| ︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\nfgh"
| | | 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 |
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\nfgh"
test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} {
# (chanPtr->flags & INPUT_SAW_CR)
# This test may fail on slower machines.
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -blocking 0 -buffering none -translation {auto lf}
fileevent $f read [namespace code "ready $f"]
|
| ︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 |
puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
| | | 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 |
puts -nonewline $f "\n01234"
after 500 [namespace code {set y ok}]
vwait [namespace which -variable y]
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel openpipe} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r"
close $f
set f [open $path(test1)]
|
| ︙ | ︙ | |||
1576 1577 1578 1579 1580 1581 1582 |
lappend l [x eval {fconfigure stderr -buffering}]
interp delete x
set l
} {line line none}
set path(test3) [makeFile {} test3]
| | | | > | | | < > | | > | | | < > | 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 |
lappend l [x eval {fconfigure stderr -buffering}]
interp delete x
set l
} {line line none}
set path(test3) [makeFile {} test3]
test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} {
set f [open $path(test1) w]
puts -nonewline $f {
close stdin
close stdout
close stderr
set f [}
puts $f [list open $path(test1) r]]
puts $f "set f2 \[[list open $path(test2) w]]"
puts $f "set f3 \[[list open $path(test3) w]]"
puts $f { puts stdout [gets stdin]
puts stdout out
puts stderr err
close $f
close $f2
close $f3
}
close $f
set result [exec [interpreter] $path(test1)]
set f [open $path(test2) r]
set f2 [open $path(test3) r]
lappend result [read $f] [read $f2]
close $f
close $f2
set result
} {{
out
} {err
}}
# This test relies on the fact that the smallest available fd is used first.
test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unixOnly} {
set f [open $path(test1) w]
puts -nonewline $f { close stdin
close stdout
close stderr
set f [}
puts $f [list open $path(test1) r]]
puts $f "set f2 \[[list open $path(test2) w]]"
puts $f "set f3 \[[list open $path(test3) w]]"
puts $f { puts stdout [gets stdin]
puts stdout $f2
puts stderr $f3
close $f
close $f2
close $f3
}
close $f
set result [exec [interpreter] $path(test1)]
set f [open $path(test2) r]
set f2 [open $path(test3) r]
lappend result [read $f] [read $f2]
close $f
close $f2
|
| ︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 |
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
| | | | | | > > | > > < > | | | > > > > > > | 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 |
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
set path(script) [makeFile {} script]
test io-14.8 {reuse of stdio special channels} {stdio openpipe} {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts -nonewline $f {
close stderr
set f [}
puts $f [list open $path(test1) w]]
puts -nonewline $f {
puts stderr hello
close $f
set f [}
puts $f [list open $path(test1) r]]
puts $f {
puts [gets $f]
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set c [gets $f]
close $f
set c
} hello
test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} {
file delete $path(script)
file delete $path(test1)
set f [open $path(script) w]
puts $f {
array set path [lindex $argv 0]
set f [open $path(test1) w]
puts $f hello
close $f
close stderr
set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
puts [gets $f]
}
close $f
set f [open "|[list [interpreter] $path(script) [array get path]]" r]
set c [gets $f]
close $f
# Added delay to give Windows time to stop the spawned process and clean
# up its grip on the file test1. Added delete as proper test cleanup.
# The failing tests were 18.1 and 18.2 as first re-users of file "test1".
after 10000
file delete $path(script)
file delete $path(test1)
set c
} hello
test io-15.1 {Tcl_CreateCloseHandler} {
} {}
test io-16.1 {Tcl_DeleteCloseHandler} {
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 |
lappend l [expr [testchannel refcount stderr] - $l1]
interp delete x
lappend l [expr [testchannel refcount stderr] - $l1]
set l
} {0 1 0}
test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
| | | | | 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 |
lappend l [expr [testchannel refcount stderr] - $l1]
interp delete x
lappend l [expr [testchannel refcount stderr] - $l1]
set l
} {0 1 0}
test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
file delete $path(test1)
set l ""
set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l] \
[list 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
file delete $path(test1)
set l ""
set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
interp create x
interp share "" $f x
lappend l [lindex [testchannel info $f] 15]
x eval close $f
lappend l [lindex [testchannel info $f] 15]
interp delete x
lappend l [lindex [testchannel info $f] 15]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l] \
[list 1 2 1 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
file delete $path(test1)
set l ""
set f [open $path(test1) w]
lappend l [lindex [testchannel info $f] 15]
interp create x
interp share "" $f x
lappend l [lindex [testchannel info $f] 15]
interp delete x
|
| ︙ | ︙ | |||
1814 1815 1816 1817 1818 1819 1820 |
[list 1 2 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
eof stdin
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
| | | | 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 |
[list 1 2 1 [format "can not find channel named \"%s\"" $f]]
} 0
test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
eof stdin
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
file delete $path(test1)
set f [open $path(test1) w]
set x [eof $f]
close $f
set x
} 0
test io-19.3 {Tcl_GetChannel, channel not found} {
list [catch {eof file34} msg] $msg
} {1 {can not find channel named "file34"}}
test io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
set l ""
lappend l [eof $f]
close $f
if {[catch {lindex [testchannel info $f] 15} msg]} {
lappend l $msg
} else {
|
| ︙ | ︙ | |||
1870 1871 1872 1873 1874 1875 1876 |
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto cr}}
set path(stdout) [makeFile {} stdout]
| | | | > > < > | | | | | | | | | | | | | > | < < > | 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 |
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto cr}}
set path(stdout) [makeFile {} stdout]
test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} {
set f [open $path(script) w]
puts -nonewline $f {
close stdout
set f1 [}
puts $f [list open $path(stdout) w]]
puts $f {
fconfigure $f1 -buffersize 777
puts stderr [fconfigure stdout -buffersize]
}
close $f
set f [open "|[list [interpreter] $path(script)]"]
catch {close $f} msg
set msg
} {777}
test io-21.1 {CloseChannelsOnExit} {
} {}
# Test management of attributes associated with a channel, such as
# its default translation, its name and type, etc. The functions
# tested in this group are Tcl_GetChannelName,
# Tcl_GetChannelType and Tcl_GetChannelFile. Tcl_GetChannelInstanceData
# not tested because files do not use the instance data.
test io-22.1 {Tcl_GetChannelMode} {
# Not used anywhere in Tcl.
} {}
test io-23.1 {Tcl_GetChannelName} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
set n [testchannel name $f]
close $f
string compare $n $f
} 0
test io-24.1 {Tcl_GetChannelType} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
set t [testchannel type $f]
close $f
string compare $t file
} 0
test io-25.1 {Tcl_GetChannelHandle, input} {testchannel} {
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f "1234567890\n098765432"
close $f
set f [open $path(test1) r]
gets $f
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {10 11}
test io-25.2 {Tcl_GetChannelHandle, output} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [tell $f]
close $f
file delete $path(test1)
set l
} {6 6 0 6}
test io-26.1 {Tcl_GetChannelInstanceData} {stdio openpipe} {
# "pid" command uses Tcl_GetChannelInstanceData
# Don't care what pid is (but must be a number), just want to exercise it.
set f [open "|[list [interpreter] << exit]"]
expr [pid $f]
close $f
} {}
# Test flushing. The functions tested here are FlushChannel.
test io-27.1 {FlushChannel, no output buffered} {
file delete $path(test1)
set f [open $path(test1) w]
flush $f
set s [file size $path(test1)]
close $f
set s
} 0
test io-27.2 {FlushChannel, some output buffered} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set l ""
puts $f hello
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 6 6}
test io-27.3 {FlushChannel, implicit flush on close} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set l ""
puts $f hello
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 6}
test io-27.4 {FlushChannel, implicit flush when buffer fills} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
fconfigure $f -buffersize 60
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
{unixOrPc} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffersize 60 -eofchar {}
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
lappend l [file size $path(test1)]
close $f
lappend l [file size $path(test1)]
set l
} {0 60 72}
set path(pipe) [makeFile {} pipe]
set path(output) [makeFile {} output]
test io-27.6 {FlushChannel, async flushing, async close} \
{stdio asyncPipeClose openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {
fconfigure $f -translation lf -buffering none -eofchar {}
while {![eof stdin]} {
after 20
puts -nonewline $f [read stdin 1024]
}
close $f
}
close $f
set x 01234567890123456789012345678901
for {set i 0} {$i < 11} {incr i} {
set x "$x$x"
}
set f [open $path(output) w]
close $f
|
| ︙ | ︙ | |||
2061 2062 2063 2064 2065 2066 2067 |
set result ok
}
} ok
# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.
test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
| | | | | | | 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 |
set result ok
}
} ok
# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.
test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
interp create x
interp share "" $f x
set l ""
lappend l [testchannel refcount $f]
x eval close $f
interp delete x
lappend l [testchannel refcount $f]
close $f
set l
} {2 1}
test io-28.2 {CloseChannel called when all references are dropped} {
file delete $path(test1)
set f [open $path(test1) w]
interp create x
interp share "" $f x
puts -nonewline $f abc
close $f
x eval puts $f def
x eval close $f
interp delete x
set f [open $path(test1) r]
set l [gets $f]
close $f
set l
} abcdef
test io-28.3 {CloseChannel, not called before output queue is empty} \
{stdio asyncPipeClose nonPortable openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f {
# Need to not have eof char appended on close, because the other
# side of the pipe already closed, so that writing would cause an
# error "invalid file".
|
| ︙ | ︙ | |||
2135 2136 2137 2138 2139 2140 2141 |
if {$counter == 1000} {
set result probably_broken
} else {
set result ok
}
} ok
test io-28.4 {Tcl_Close} {testchannel} {
| | | | | | | | | | | | 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 |
if {$counter == 1000} {
set result probably_broken
} else {
set result ok
}
} ok
test io-28.4 {Tcl_Close} {testchannel} {
file delete $path(test1)
set l ""
lappend l [lsort [testchannel open]]
set f [open $path(test1) w]
lappend l [lsort [testchannel open]]
close $f
lappend l [lsort [testchannel open]]
set x [list $consoleFileNames \
[lsort [eval list $consoleFileNames $f]] \
$consoleFileNames]
string compare $l $x
} 0
test io-28.5 {Tcl_Close vs standard handles} {stdio unixOnly testchannel openpipe} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
close stdin
puts [testchannel open]
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
set l [gets $f]
close $f
set l
} {file1 file2}
test io-29.1 {Tcl_WriteChars, channel not writable} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.2 {Tcl_WriteChars, empty string} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar {}
puts -nonewline $f ""
close $f
file size $path(test1)
} 0
test io-29.3 {Tcl_WriteChars, nonempty string} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar {}
puts -nonewline $f hello
close $f
file size $path(test1)
} 5
test io-29.4 {Tcl_WriteChars, buffering in full buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full -eofchar {}
puts $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {6 0 0 6}
test io-29.5 {Tcl_WriteChars, buffering in line buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering line -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {5 0 0 11}
test io-29.6 {Tcl_WriteChars, buffering in no buffering mode} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering none -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {0 5 0 11}
test io-29.7 {Tcl_Flush, full buffering} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering full -eofchar {}
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
puts $f hello
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
close $f
set l
} {5 0 11 0 0 11}
test io-29.8 {Tcl_Flush, full buffering} {testchannel} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffering line
puts -nonewline $f hello
set l ""
lappend l [testchannel outputbuffered $f]
lappend l [file size $path(test1)]
flush $f
|
| ︙ | ︙ | |||
2264 2265 2266 2267 2268 2269 2270 |
close $f
set l
} {5 0 0 5 0 11 0 11}
test io-29.9 {Tcl_Flush, channel not writable} {
list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.10 {Tcl_WriteChars, looping and buffering} {
| | | | | | > | < < > | | | | 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 |
close $f
set l
} {5 0 0 5 0 11 0 11}
test io-29.9 {Tcl_Flush, channel not writable} {
list [catch {flush stdin} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
test io-29.10 {Tcl_WriteChars, looping and buffering} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts $f1 [gets $f2]
}
close $f2
close $f1
file size $path(test1)
} 387
test io-29.11 {Tcl_WriteChars, no newline, implicit flush} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -eofchar {}
set f2 [open $path(longfile) r]
for {set x 0} {$x < 10} {incr x} {
puts -nonewline $f1 [gets $f2]
}
close $f1
close $f2
file size $path(test1)
} 377
test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 "set f1 \[[list open $path(longfile) r]]"
puts $f1 {
for {set x 0} {$x < 10} {incr x} {
puts [gets $f1]
}
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r]
set f2 [open $path(longfile) r]
set y ok
for {set x 0} {$x < 10} {incr x} {
set l1 [gets $f1]
set l2 [gets $f2]
if {"$l1" != "$l2"} {
set y broken
}
}
close $f1
close $f2
set y
} ok
test io-29.13 {Tcl_WriteChars to a pipe, line buffered} {stdio openpipe} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts [gets stdin]
puts [gets stdin]
}
close $f1
set y ok
|
| ︙ | ︙ | |||
2342 2343 2344 2345 2346 2347 2348 |
set y broken
}
close $f1
close $f2
set y
} ok
test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} {
| | | | | | | | | | | | | 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 |
set y broken
}
close $f1
close $f2
set y
} ok
test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "Text1"
puts -nonewline $f " Text 2"
puts $f " Text 3"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} {Text1 Text 2 Text 3}
test io-29.15 {Tcl_Flush, channel not open for writing} {
file delete $path(test1)
set fd [open $path(test1) w]
close $fd
set fd [open $path(test1) r]
set x [list [catch {flush $fd} msg] $msg]
close $fd
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.16 {Tcl_Flush on pipe opened only for reading} {stdio openpipe} {
set fd [open "|[list [interpreter] cat longfile]" r]
set x [list [catch {flush $fd} msg] $msg]
catch {close $fd}
string compare $x \
[list 1 "channel \"$fd\" wasn't opened for writing"]
} 0
test io-29.17 {Tcl_WriteChars buffers, then Tcl_Flush flushes} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
set x [file size $path(test1)]
close $f1
set x
} 18
test io-29.18 {Tcl_WriteChars and Tcl_Flush intermixed} {
file delete $path(test1)
set x ""
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
close $f1
set x
} {18 24 30}
test io-29.19 {Explicit and implicit flushes} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set x ""
puts $f1 hello
puts $f1 hello
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
flush $f1
lappend x [file size $path(test1)]
puts $f1 hello
close $f1
lappend x [file size $path(test1)]
set x
} {18 24 30}
test io-29.20 {Implicit flush when buffer is full} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
set line "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
for {set x 0} {$x < 100} {incr x} {
puts $f1 $line
}
set z ""
lappend z [file size $path(test1)]
for {set x 0} {$x < 100} {incr x} {
puts $f1 $line
}
lappend z [file size $path(test1)]
close $f1
lappend z [file size $path(test1)]
set z
} {4096 12288 12600}
test io-29.21 {Tcl_Flush to pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {set x [read stdin 6]}
puts $f1 {set cnt [string length $x]}
puts $f1 {puts "read $cnt characters"}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
catch {close $f1}
set x
} "read 6 characters"
test io-29.22 {Tcl_Flush called at other end of pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
fconfigure stdout -buffering full
puts hello
puts hello
flush stdout
gets stdin
|
| ︙ | ︙ | |||
2474 2475 2476 2477 2478 2479 2480 |
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
| | | | 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 |
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
test io-29.23 {Tcl_Flush and line buffering at end of pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts hello
puts hello
gets stdin
puts bye
}
|
| ︙ | ︙ | |||
2509 2510 2511 2512 2513 2514 2515 |
flush $f
set f2 [open $path(test3)]
lappend x [read -nonewline $f2]
close $f2
close $f
set x
} "{} {Line 1\nLine 2}"
| | | | | | | 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 |
flush $f
set f2 [open $path(test3)]
lappend x [read -nonewline $f2]
close $f2
close $f
set x
} "{} {Line 1\nLine 2}"
test io-29.25 {Implicit flush with Tcl_Flush to command pipelines} {stdio openpipe fileevent} {
file delete $path(test3)
set f [open "|[list [interpreter] $path(cat) | [interpreter] $path(cat) > $path(test3)]" w]
puts $f "Line 1"
puts $f "Line 2"
close $f
after 100
set f [open $path(test3) r]
set x [read $f]
close $f
set x
} "Line 1\nLine 2\n"
test io-29.26 {Tcl_Flush, Tcl_Write on bidirectional pipelines} {stdio unixExecs openpipe} {
set f [open "|[list cat -u]" r+]
puts $f "Line1"
flush $f
set x [gets $f]
close $f
set x
} {Line1}
test io-29.27 {Tcl_Flush on closed pipeline} {stdio openpipe} {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {exit}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r+]
gets $f
puts $f output
after 50
|
| ︙ | ︙ | |||
2558 2559 2560 2561 2562 2563 2564 |
set x {this was supposed to fail and did not}
}
}
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
| | | | | | | | | 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 |
set x {this was supposed to fail and did not}
}
}
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f hello\nthere\nand\nhere
flush $f
set s [file size $path(test1)]
close $f
set s
} 21
test io-29.29 {Tcl_WriteChars, cr mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 21
test io-29.30 {Tcl_WriteChars, crlf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
puts $f hello\nthere\nand\nhere
close $f
file size $path(test1)
} 25
test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {fconfigure $f -translation lf}
set x [list while {![eof stdin]}]
set x "$x {"
puts $f $x
puts $f { puts -nonewline $f [read stdin 4096]}
puts $f { flush $f}
puts $f "}"
|
| ︙ | ︙ | |||
2620 2621 2622 2623 2624 2625 2626 |
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
| | | | | | 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 |
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
{stdio asyncPipeClose openpipe} {
file delete $path(pipe)
file delete $path(output)
set f [open $path(pipe) w]
puts $f "set f \[[list open $path(output) w]]"
puts $f {fconfigure $f -translation lf}
set x [list while {![eof stdin]}]
set x "$x \{"
puts $f $x
puts $f { after 20}
puts $f { puts -nonewline $f [read stdin 1024]}
puts $f { flush $f}
|
| ︙ | ︙ | |||
2659 2660 2661 2662 2663 2664 2665 |
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
set f [open $path(script) w]
| | < | < > | | | 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 |
set result "file size only [file size $path(output)]"
} else {
set result ok
}
} ok
test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
set f [open $path(script) w]
puts $f "set f \[[list open $path(test1) w]]"
puts $f {fconfigure $f -translation lf
puts $f hello
puts $f bye
puts $f strange
}
close $f
exec [interpreter] $path(script)
set f [open $path(test1) r]
set r [read $f]
close $f
set r
} "hello\nbye\nstrange\n"
test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} {
variable c 0
variable x running
set l abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz
proc writelots {s l} {
for {set i 0} {$i < 2000} {incr i} {
puts $s $l
}
}
|
| ︙ | ︙ | |||
2710 2711 2712 2713 2714 2715 2716 |
fconfigure $cs -blocking off
writelots $cs $l
close $cs
close $ss
vwait [namespace which -variable x]
set c
} 2000
| | | 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 |
fconfigure $cs -blocking off
writelots $cs $l
close $cs
close $ss
vwait [namespace which -variable x]
set c
} 2000
test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotMac fileevent} {
# On Mac, this test screws up sockets such that subsequent tests using port 2828
# either cause errors or panic().
catch {interp delete x}
catch {interp delete y}
interp create x
interp create y
|
| ︙ | ︙ | |||
2755 2756 2757 2758 2759 2760 2761 |
interp delete x
interp delete y
} ""
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
| | | | | | | | | | | | | | | | | | | | | | 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 |
interp delete x
interp delete y
} ""
# Test end of line translations. Procedures tested are Tcl_Write, Tcl_Read.
test io-30.1 {Tcl_Write lf, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.2 {Tcl_Write lf, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.3 {Tcl_Write lf, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.4 {Tcl_Write cr, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.5 {Tcl_Write cr, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hello\rthere\rand\rhere\r"
test io-30.6 {Tcl_Write cr, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hello\rthere\rand\rhere\r"
test io-30.7 {Tcl_Write crlf, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "hello\nthere\nand\nhere\n"
test io-30.8 {Tcl_Write crlf, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set x [read $f]
close $f
set x
} "hello\r\nthere\r\nand\r\nhere\r\n"
test io-30.9 {Tcl_Write crlf, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "hello\n\nthere\n\nand\n\nhere\n\n"
test io-30.10 {Tcl_Write lf, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
list $c $x
} {{hello
there
and
here
} auto}
test io-30.11 {Tcl_Write cr, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
list $c $x
} {{hello
there
and
here
} auto}
test io-30.12 {Tcl_Write crlf, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set c [read $f]
set x [fconfigure $f -translation]
close $f
list $c $x
} {{hello
there
and
here
} auto}
test io-30.13 {Tcl_Write crlf on block boundary, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set c [read $f]
close $f
string length $c
} [expr 700*15+1]
test io-30.14 {Tcl_Write crlf on block boundary, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set c [read $f]
close $f
string length $c
} [expr 700*15+1]
test io-30.15 {Tcl_Write mixed, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.16 {Tcl_Write ^Z at end, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\nand\rhere\n\x1a
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.17 {Tcl_Write, implicit ^Z at end, Tcl_Read auto} {pcOnly} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar \x1a -translation lf
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set c [read $f]
close $f
set c
} {hello
there
and
here
}
test io-30.18 {Tcl_Write, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1 {} 1}
test io-30.19 {Tcl_Write, ^Z no newline in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1 {} 1}
test io-30.20 {Tcl_Write, ^Z in middle ignored, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar {}
|
| ︙ | ︙ | |||
3056 3057 3058 3059 3060 3061 3062 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aghi 0 qrs 0 {} 1"
test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aghi 0 qrs 0 {} 1"
test io-30.21 {Tcl_Write, ^Z in middle ignored, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar {}
set l ""
set x [gets $f]
lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {0 1 {} 1}
test io-30.22 {Tcl_Write, ^Z in middle ignored, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cghi\nqrs" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar {}
set l ""
set x [gets $f]
lappend l [string compare $x "abc\ndef\n\x1aghi\nqrs\n"]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {0 1 {} 1}
test io-30.23 {Tcl_Write lf, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.24 {Tcl_Write lf, ^Z in middle, Tcl_Read lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.25 {Tcl_Write cr, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.26 {Tcl_Write cr, ^Z in middle, Tcl_Read cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.27 {Tcl_Write crlf, ^Z in middle, Tcl_Read auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
test io-30.28 {Tcl_Write crlf, ^Z in middle, Tcl_Read crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format abc\ndef\n%cqrs\ntuv 26]
puts $f $c
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set c [string length [read $f]]
set e [eof $f]
close $f
list $c $e
} {8 1}
# Test end of line translations. Functions tested are Tcl_Write and Tcl_Gets.
test io-31.1 {Tcl_Write lf, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 6 auto there 12 auto}
test io-31.2 {Tcl_Write cr, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 6 auto there 12 auto}
test io-31.3 {Tcl_Write crlf, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 7 auto there 14 auto}
test io-31.4 {Tcl_Write lf, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
close $f
set l
} {hello 6 lf there 12 lf}
test io-31.5 {Tcl_Write lf, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 cr 1 {} 21 cr 1}
test io-31.6 {Tcl_Write lf, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.7 {Tcl_Write cr, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {hello 6 cr 0 there 12 cr 0}
test io-31.8 {Tcl_Write cr, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 lf 1 {} 21 lf 1}
test io-31.9 {Tcl_Write cr, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {21 21 crlf 1 {} 21 crlf 1}
test io-31.10 {Tcl_Write crlf, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {hello 7 crlf 0 there 14 crlf 0}
test io-31.11 {Tcl_Write crlf, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr
set l ""
lappend l [gets $f]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {hello 6 cr 0 6 13 cr 0}
test io-31.12 {Tcl_Write crlf, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f hello\nthere\nand\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf
set l ""
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
lappend l [string length [gets $f]]
lappend l [tell $f]
lappend l [fconfigure $f -translation]
lappend l [eof $f]
close $f
set l
} {6 7 lf 0 6 14 lf 0}
test io-31.13 {binary mode is synonym of lf mode} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation binary
set x [fconfigure $f -translation]
close $f
set x
} lf
#
# Test io-9.14 has been removed because "auto" output translation mode is
# not supoprted.
#
test io-31.14 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts $f hello\nthere\rand\r\nhere
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.15 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\rand\r\nhere\r
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.16 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\rand\r\nhere\n
close $f
set f [open $path(test1) r]
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.17 {Tcl_Write mixed, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f hello\nthere\rand\r\nhere\r\n
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.18 {Tcl_Write ^Z at end, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "hello\nthere\nand\rhere\n\%c" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.19 {Tcl_Write, implicit ^Z at end, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -eofchar \x1a -translation lf
puts $f hello\nthere\nand\rhere
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {hello there and here 0 {} 1}
test io-31.20 {Tcl_Write, ^Z in middle, Tcl_Gets auto, eofChar} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a
fconfigure $f -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.21 {Tcl_Write, no newline ^Z in middle, Tcl_Gets auto, eofChar} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.22 {Tcl_Write, ^Z in middle ignored, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar {}
|
| ︙ | ︙ | |||
3593 3594 3595 3596 3597 3598 3599 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
| | | 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.23 {Tcl_Write, ^Z in middle ignored, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar {}
|
| ︙ | ︙ | |||
3615 3616 3617 3618 3619 3620 3621 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
| | | 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.24 {Tcl_Write, ^Z in middle ignored, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar {}
|
| ︙ | ︙ | |||
3637 3638 3639 3640 3641 3642 3643 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
| | | | | | | | | | 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 |
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} "abc def 0 \x1aqrs 0 tuv 0 {} 1"
test io-31.25 {Tcl_Write lf, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.26 {Tcl_Write lf, ^Z in middle, Tcl_Gets lf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.27 {Tcl_Write cr, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.28 {Tcl_Write cr, ^Z in middle, Tcl_Gets cr} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.29 {Tcl_Write crlf, ^Z in middle, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.30 {Tcl_Write crlf, ^Z in middle, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set s [format "abc\ndef\n%cqrs\ntuv" 26]
puts $f $s
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set l ""
lappend l [gets $f]
lappend l [gets $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {abc def 0 {} 1}
test io-31.31 {Tcl_Write crlf on block boundary, Tcl_Gets crlf} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
close $f
set f [open $path(test1) r]
fconfigure $f -translation crlf
set c ""
while {[gets $f line] >= 0} {
append c $line\n
}
close $f
string length $c
} [expr 700*15+1]
test io-31.32 {Tcl_Write crlf on block boundary, Tcl_Gets auto} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set line "123456789ABCDE" ;# 14 char plus crlf
puts -nonewline $f x ;# shift crlf across block boundary
for {set i 0} {$i < 700} {incr i} {
puts $f $line
}
|
| ︙ | ︙ | |||
3864 3865 3866 3867 3868 3869 3870 |
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
| | | | | | | | | | | | 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 |
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.10 {Tcl_Read from a pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [read $f1]
close $f1
set x
} "hello\n"
test io-32.11 {Tcl_Read from a pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x ""
lappend x [read $f1 6]
puts $f1 hello
flush $f1
lappend x [read $f1]
close $f1
set x
} {{hello
} {hello
}}
test io-32.12 {Tcl_Read, -nonewline} {
file delete $path(test1)
set f1 [open $path(test1) w]
puts $f1 hello
puts $f1 bye
close $f1
set f1 [open $path(test1) r]
set c [read -nonewline $f1]
close $f1
set c
} {hello
bye}
test io-32.13 {Tcl_Read, -nonewline} {
file delete $path(test1)
set f1 [open $path(test1) w]
puts $f1 hello
puts $f1 bye
close $f1
set f1 [open $path(test1) r]
set c [read -nonewline $f1]
close $f1
list [string length $c] $c
} {9 {hello
bye}}
test io-32.14 {Tcl_Read, reading in small chunks} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [list [read $f 1] [read $f 2] [read $f]]
close $f
set x
} {T wo { lines: this one
and this one
}}
test io-32.15 {Tcl_Read, asking for more input than available} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [read $f 100]
close $f
set x
} {Two lines: this one
and this one
}
test io-32.16 {Tcl_Read, read to end of file with -nonewline} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [read -nonewline $f]
close $f
set x
} {Two lines: this one
and this one}
# Test Tcl_Gets.
test io-33.1 {Tcl_Gets, reading what was written} {
file delete $path(test1)
set f1 [open $path(test1) w]
set y "first line"
puts $f1 $y
close $f1
set f1 [open $path(test1) r]
set x [gets $f1]
set z ok
|
| ︙ | ︙ | |||
3986 3987 3988 3989 3990 3991 3992 |
set z ok
if {$l != $l} {
set z broken
}
close $f1
set z
} ok
| | | | | | 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 |
set z ok
if {$l != $l} {
set z broken
}
close $f1
set z
} ok
test io-33.3 {Tcl_Gets from pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {puts [gets stdin]}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
flush $f1
set x [gets $f1]
close $f1
set z ok
if {"$x" != "hello"} {
set z broken
}
set z
} ok
test io-33.4 {Tcl_Gets with long line} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
puts $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
set f [open $path(test3)]
set x [gets $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.5 {Tcl_Gets with long line} {
set f [open $path(test3)]
set x [gets $f y]
close $f
list $x $y
} {260 abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ}
test io-33.6 {Tcl_Gets and end of file} {
file delete $path(test3)
set f [open $path(test3) w]
puts -nonewline $f "Test1\nTest2"
close $f
set f [open $path(test3)]
set x {}
set y {}
lappend x [gets $f y] $y
|
| ︙ | ︙ | |||
4100 4101 4102 4103 4104 4105 4106 |
set f1 [open $path(longfile) r]
seek $f1 0 current
set c [tell $f1]
close $f1
set c
} 0
test io-34.2 {Tcl_Seek to offset from start} {
| | | | | | | | | | 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 |
set f1 [open $path(longfile) r]
seek $f1 0 current
set c [tell $f1]
close $f1
set c
} 0
test io-34.2 {Tcl_Seek to offset from start} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 start
set c [tell $f1]
close $f1
set c
} 10
test io-34.3 {Tcl_Seek to end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 0 end
set c [tell $f1]
close $f1
set c
} 54
test io-34.4 {Tcl_Seek to offset from end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
close $f1
set c
} 44
test io-34.5 {Tcl_Seek to offset from current position} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 current
seek $f1 10 current
set c [tell $f1]
close $f1
set c
} 20
test io-34.6 {Tcl_Seek to offset from end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c [tell $f1]
set r [read $f1]
close $f1
list $c $r
} {44 {rstuvwxyz
}}
test io-34.7 {Tcl_Seek to offset from end of file, then to current position} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 -10 end
set c1 [tell $f1]
set r1 [read $f1 5]
seek $f1 0 current
set c2 [tell $f1]
close $f1
list $c1 $r1 $c2
} {44 rstuv 49}
test io-34.8 {Tcl_Seek on pipes: not supported} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
set x [list [catch {seek $f1 0 current} msg] $msg]
close $f1
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error during seek on "": invalid argument}}
test io-34.9 {Tcl_Seek, testing buffered input flushing} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -eofchar {}
puts -nonewline $f "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
close $f
set f [open $path(test3) RDWR]
set x [read $f 1]
seek $f 3
|
| ︙ | ︙ | |||
4259 4260 4261 4262 4263 4264 4265 |
set y [gets $f]
close $f
list $x [viewFile test3] $y
} {14 {xyz
123
xyzzy} zzy}
test io-34.13 {Tcl_Tell at start of file} {
| | | | | | | | 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 |
set y [gets $f]
close $f
list $x [viewFile test3] $y
} {14 {xyz
123
xyzzy} zzy}
test io-34.13 {Tcl_Tell at start of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
set p [tell $f1]
close $f1
set p
} 0
test io-34.14 {Tcl_Tell after seek to end of file} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 0 end
set c1 [tell $f1]
close $f1
set c1
} 54
test io-34.15 {Tcl_Tell combined with seeking} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {}
puts $f1 "abcdefghijklmnopqrstuvwxyz"
puts $f1 "abcdefghijklmnopqrstuvwxyz"
close $f1
set f1 [open $path(test1) r]
seek $f1 10 start
set c1 [tell $f1]
seek $f1 10 current
set c2 [tell $f1]
close $f1
list $c1 $c2
} {10 20}
test io-34.16 {Tcl_tell on pipe: always -1} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
set c [tell $f1]
close $f1
set c
} -1
test io-34.17 {Tcl_Tell on pipe: always -1} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello}
flush $f1
set c [tell $f1]
gets $f1
close $f1
set c
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
file delete $path(test2)
set f [open $path(test2) w]
fconfigure $f -translation lf -eofchar {}
puts -nonewline $f "line1\nline2\nline3\nline4\nline5\n"
close $f
set f [open $path(test2)]
fconfigure $f -translation lf
set x [tell $f]
|
| ︙ | ︙ | |||
4355 4356 4357 4358 4359 4360 4361 |
lappend l [tell $f]
seek $f 407 end
lappend l [tell $f]
close $f
set l
} {29 39 40 447}
test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
| | | 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 |
lappend l [tell $f]
seek $f 407 end
lappend l [tell $f]
close $f
set l
} {29 39 40 447}
test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -encoding binary
set l ""
lappend l [tell $f]
puts -nonewline $f abcdef
lappend l [tell $f]
flush $f
|
| ︙ | ︙ | |||
4380 4381 4382 4383 4384 4385 4386 |
lappend l [file size $f]
set l
} {0 6 6 4294967296 4294967302 4294967302 0}
# Test Tcl_Eof
test io-35.1 {Tcl_Eof} {
| | | | | | | 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 |
lappend l [file size $f]
set l
} {0 6 6 4294967296 4294967302 4294967302 0}
# Test Tcl_Eof
test io-35.1 {Tcl_Eof} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f hello
puts $f hello
close $f
set f [open $path(test1)]
set x [eof $f]
lappend x [eof $f]
gets $f
lappend x [eof $f]
gets $f
lappend x [eof $f]
gets $f
lappend x [eof $f]
lappend x [eof $f]
close $f
set x
} {0 0 0 0 1 1}
test io-35.2 {Tcl_Eof with pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
flush $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
close $f1
set x
} {0 0 0 1}
test io-35.3 {Tcl_Eof with pipe} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {gets stdin}
puts $f1 {puts hello}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
puts $f1 hello
set x [eof $f1]
|
| ︙ | ︙ | |||
4439 4440 4441 4442 4443 4444 4445 |
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
close $f1
set x
} {0 0 0 1 1 1}
test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
| | | | | | | | | | | | | | | | | | | | | | | | | 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 |
lappend x [eof $f1]
gets $f1
lappend x [eof $f1]
close $f1
set x
} {0 0 0 1 1 1}
test io-35.4 {Tcl_Eof, eof detection on nonblocking file} {nonBlockFiles} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
test io-35.5 {Tcl_Eof, eof detection on nonblocking pipe} {stdio openpipe} {
file delete $path(pipe)
set f [open $path(pipe) w]
puts $f {
exit
}
close $f
set f [open "|[list [interpreter] $path(pipe)]" r]
set l ""
lappend l [gets $f]
lappend l [eof $f]
close $f
set l
} {{} 1}
test io-35.6 {Tcl_Eof, eof char, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {9 8 1}
test io-35.7 {Tcl_Eof, eof char, lf write, lf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {9 8 1}
test io-35.8 {Tcl_Eof, eof char, cr write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {9 8 1}
test io-35.9 {Tcl_Eof, eof char, cr write, cr read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {9 8 1}
test io-35.10 {Tcl_Eof, eof char, crlf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {11 8 1}
test io-35.11 {Tcl_Eof, eof char, crlf write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar \x1a
puts $f abc\ndef
close $f
set s [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $s $l $e
} {11 8 1}
test io-35.12 {Tcl_Eof, eof char in middle, lf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.13 {Tcl_Eof, eof char in middle, lf write, lf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.14 {Tcl_Eof, eof char in middle, cr write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.15 {Tcl_Eof, eof char in middle, cr write, cr read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {17 8 1}
test io-35.16 {Tcl_Eof, eof char in middle, crlf write, auto read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {21 8 1}
test io-35.17 {Tcl_Eof, eof char in middle, crlf write, crlf read} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf -eofchar {}
set i [format abc\ndef\n%cqrs\nuvw 26]
puts $f $i
close $f
set c [file size $path(test1)]
set f [open $path(test1) r]
fconfigure $f -translation crlf -eofchar \x1a
set l [string length [read $f]]
set e [eof $f]
close $f
list $c $l $e
} {21 8 1}
# Test Tcl_InputBlocked
test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
puts $f1 {puts hello_from_pipe}
flush $f1
gets $f1
fconfigure $f1 -blocking off -buffering full
puts $f1 {puts hello}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
flush $f1
after 200
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [gets $f1]
lappend x [fblocked $f1]
close $f1
set x
} {{} 1 hello 0 {} 1}
test io-36.2 {Tcl_InputBlocked on blocking pipe} {stdio openpipe} {
set f1 [open "|[list [interpreter]]" r+]
fconfigure $f1 -buffering line
puts $f1 {puts hello_from_pipe}
set x ""
lappend x [gets $f1]
lappend x [fblocked $f1]
puts $f1 {exit}
lappend x [gets $f1]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {hello_from_pipe 0 {} 0 1}
test io-36.3 {Tcl_InputBlocked vs files, short read} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
set l ""
lappend l [fblocked $f]
lappend l [read $f 3]
lappend l [fblocked $f]
lappend l [read -nonewline $f]
lappend l [fblocked $f]
lappend l [eof $f]
close $f
set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} {
proc in {f} {
variable l
variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
set l ""
fileevent $f readable [namespace code [list in $f]]
variable x
vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
} eof}
test io-36.5 {Tcl_InputBlocked vs files, short read, nonblocking} {nonBlockFiles} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
lappend l [fblocked $f]
lappend l [read $f 3]
lappend l [fblocked $f]
lappend l [read -nonewline $f]
lappend l [fblocked $f]
lappend l [eof $f]
close $f
set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} {
proc in {f} {
variable l
variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
file delete $path(test1)
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1) r]
fconfigure $f -blocking off
set l ""
fileevent $f readable [namespace code [list in $f]]
|
| ︙ | ︙ | |||
4799 4800 4801 4802 4803 4804 4805 |
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 100000
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000000
lappend l [fconfigure $f -buffersize]
close $f
set l
| | | | | | | | | | | | | | 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 |
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 100000
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000000
lappend l [fconfigure $f -buffersize]
close $f
set l
} {4096 10000 1 1 1 100000 100000}
test io-38.3 {Tcl_SetChannelBufferSize, changing buffersize between reads} {
# This test crashes the interp if Bug #427196 is not fixed
set chan [open [info script] r]
fconfigure $chan -buffersize 10
set var [read $chan 2]
fconfigure $chan -buffersize 32
append var [read $chan]
close $chan
} {}
# Test Tcl_SetChannelOption, Tcl_GetChannelOption
test io-39.1 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
set x [fconfigure $f1 -blocking]
close $f1
set x
} 1
#
# Test 17.2 was removed.
#
test io-39.2 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
set x [fconfigure $f1 -buffering]
close $f1
set x
} full
test io-39.3 {Tcl_GetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -buffering line
set x [fconfigure $f1 -buffering]
close $f1
set x
} line
test io-39.4 {Tcl_GetChannelOption, Tcl_SetChannelOption} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering line
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering none
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering line
lappend l [fconfigure $f1 -buffering]
fconfigure $f1 -buffering full
lappend l [fconfigure $f1 -buffering]
close $f1
set l
} {full line none line full}
test io-39.5 {Tcl_GetChannelOption, invariance} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
lappend l [fconfigure $f1 -buffering]
lappend l [list [catch {fconfigure $f1 -buffering green} msg] $msg]
lappend l [fconfigure $f1 -buffering]
close $f1
set l
} {full {1 {bad value for -buffering: must be one of full, line, or none}} full}
test io-39.6 {Tcl_SetChannelOption, multiple options} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line
puts $f1 hello
puts $f1 bye
set x [file size $path(test1)]
close $f1
set x
} 10
test io-39.7 {Tcl_SetChannelOption, buffering, translation} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf
puts $f1 hello
puts $f1 bye
set x ""
fconfigure $f1 -buffering line
lappend x [file size $path(test1)]
puts $f1 really_bye
lappend x [file size $path(test1)]
close $f1
set x
} {0 21}
test io-39.8 {Tcl_SetChannelOption, different buffering options} {
file delete $path(test1)
set f1 [open $path(test1) w]
set l ""
fconfigure $f1 -translation lf -buffering none -eofchar {}
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
fconfigure $f1 -buffering full
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
fconfigure $f1 -buffering none
lappend l [file size $path(test1)]
puts -nonewline $f1 hello
lappend l [file size $path(test1)]
close $f1
lappend l [file size $path(test1)]
set l
} {5 10 10 10 20 20}
test io-39.9 {Tcl_SetChannelOption, blocking mode} {nonBlockFiles} {
file delete $path(test1)
set f1 [open $path(test1) w]
close $f1
set f1 [open $path(test1) r]
set x ""
lappend x [fconfigure $f1 -blocking]
fconfigure $f1 -blocking off
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
lappend x [read $f1 1000]
lappend x [fblocked $f1]
lappend x [eof $f1]
close $f1
set x
} {1 0 {} {} 0 1}
test io-39.10 {Tcl_SetChannelOption, blocking mode} {stdio openpipe} {
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
gets stdin
after 100
puts hi
gets stdin
}
|
| ︙ | ︙ | |||
4962 4963 4964 4965 4966 4967 4968 |
lappend x [eof $f1]
lappend x [gets $f1]
lappend x [eof $f1]
close $f1
set x
} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
| | | | | | | | | 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 |
lappend x [eof $f1]
lappend x [gets $f1]
lappend x [eof $f1]
close $f1
set x
} {0 {} 1 {} 1 {} 1 1 hi 0 0 {} 1}
test io-39.11 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -buffersize -10
set x [fconfigure $f -buffersize]
close $f
set x
} 4096
test io-39.12 {Tcl_SetChannelOption, Tcl_GetChannelOption buffer size} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -buffersize 10000000
set x [fconfigure $f -buffersize]
close $f
set x
} 4096
test io-39.13 {Tcl_SetChannelOption, Tcl_GetChannelOption, buffer size} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -buffersize 40000
set x [fconfigure $f -buffersize]
close $f
set x
} 40000
test io-39.14 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -encoding {}
puts -nonewline $f \xe7\x89\xa6
close $f
set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
set x
} \u7266
test io-39.15 {Tcl_SetChannelOption: -encoding, binary & utf-8} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f \xe7\x89\xa6
close $f
set f [open $path(test1) r]
fconfigure $f -encoding utf-8
set x [read $f]
close $f
set x
} \u7266
test io-39.16 {Tcl_SetChannelOption: -encoding, errors} {
file delete $path(test1)
set f [open $path(test1) w]
set result [list [catch {fconfigure $f -encoding foobar} msg] $msg]
close $f
set result
} {1 {unknown encoding "foobar"}}
test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA} {stdio openpipe fileevent} {
set f [open "|[list [interpreter] $path(cat)]" r+]
fconfigure $f -encoding binary
puts -nonewline $f "\xe7"
flush $f
fconfigure $f -encoding utf-8 -blocking 0
variable x {}
fileevent $f readable [namespace code { lappend x [read $f] }]
|
| ︙ | ︙ | |||
5093 5094 5095 5096 5097 5098 5099 |
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto crlf}
test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
| | | | 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 |
set modes [fconfigure $s2 -translation]
close $s1
close $s2
set modes
} {auto crlf}
test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l ""
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar {ON GO}
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar D
lappend l [fconfigure $f1 -eofchar]
close $f1
set l
} {{{} {}} {O G} {D D}}
test io-39.22a {Tcl_SetChannelOption, invariance} {
file delete $path(test1)
set f1 [open $path(test1) w+]
set l [list]
fconfigure $f1 -eofchar {ON GO}
lappend l [fconfigure $f1 -eofchar]
fconfigure $f1 -eofchar D
lappend l [fconfigure $f1 -eofchar]
lappend l [list [catch {fconfigure $f1 -eofchar {1 2 3}} msg] $msg]
|
| ︙ | ︙ | |||
5138 5139 5140 5141 5142 5143 5144 |
fconfigure $sock -eofchar D -translation lf
lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
close $sock
set l
} {{{}} auto}
test io-40.1 {POSIX open access modes: RDWR} {
| | | | | | | | | < < < | | | | | | | < < | | | | < < | | | | < < | | < | | | > | < | | | | | | | | | < < < < < < < | | > > > > > > | | > > > > > > | | > > > > > > | | > > > > > > | | > > > > > > | | < < < | | | | 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 |
fconfigure $sock -eofchar D -translation lf
lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
close $sock
set l
} {{{}} auto}
test io-40.1 {POSIX open access modes: RDWR} {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
set f [open $path(test3) RDWR]
puts -nonewline $f "ab"
seek $f 0 current
set x [gets $f]
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {zzy abzzy}
test io-40.2 {POSIX open access modes: CREAT} {unixOnly} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT} 0600]
file stat $path(test3) stats
set x [format "0%o" [expr $stats(mode)&0777]]
puts $f "line 1"
close $f
set f [open $path(test3) r]
lappend x [gets $f]
close $f
set x
} {0600 {line 1}}
# some tests can only be run is umask is 2
# if "umask" cannot be run, the tests will be skipped.
catch {testConstraint umask2 [expr {[exec umask] == 2}]}
test io-40.3 {POSIX open access modes: CREAT} {unixOnly umask2} {
# This test only works if your umask is 2, like ouster's.
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT}]
close $f
file stat test3 stats
format "0%o" [expr $stats(mode)&0777]
} 0664
test io-40.4 {POSIX open access modes: CREAT} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -eofchar {}
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY CREAT}]
fconfigure $f -eofchar {}
puts -nonewline $f "ab"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} abzzy
test io-40.5 {POSIX open access modes: APPEND} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY APPEND}]
fconfigure $f -translation lf
puts $f "new line"
seek $f 0
puts $f "abc"
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
set x ""
seek $f 6 current
lappend x [gets $f]
lappend x [gets $f]
close $f
set x
} {{new line} abc}
test io-40.6 {POSIX open access modes: EXCL} -match regexp -body {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
open $path(test3) {WRONLY CREAT EXCL}
} -returnCodes error -result {(?i)couldn't open ".*test3": file (already )?exists}
test io-40.7 {POSIX open access modes: EXCL} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT EXCL}]
fconfigure $f -eofchar {}
puts $f "A test line"
close $f
viewFile test3
} {A test line}
test io-40.8 {POSIX open access modes: TRUNC} {
file delete $path(test3)
set f [open $path(test3) w]
puts $f xyzzy
close $f
set f [open $path(test3) {WRONLY TRUNC}]
puts $f abc
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} abc
test io-40.9 {POSIX open access modes: NONBLOCK} {nonPortable macOrUnix} {
file delete $path(test3)
set f [open $path(test3) {WRONLY NONBLOCK CREAT}]
puts $f "NONBLOCK test"
close $f
set f [open $path(test3) r]
set x [gets $f]
close $f
set x
} {NONBLOCK test}
test io-40.10 {POSIX open access modes: RDONLY} {
set f [open $path(test1) w]
puts $f "two lines: this one"
puts $f "and this"
close $f
set f [open $path(test1) RDONLY]
set x [list [gets $f] [catch {puts $f Test} msg] $msg]
close $f
string compare [string tolower $x] \
[list {two lines: this one} 1 \
[format "channel \"%s\" wasn't opened for writing" $f]]
} 0
test io-40.11 {POSIX open access modes: RDONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) RDONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.12 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.13 {POSIX open access modes: WRONLY} {
makeFile xyzzy test3
set f [open $path(test3) WRONLY]
fconfigure $f -eofchar {}
puts -nonewline $f "ab"
seek $f 0 current
set x [list [catch {gets $f} msg] $msg]
close $f
lappend x [viewFile test3]
string compare [string tolower $x] \
[list 1 "channel \"$f\" wasn't opened for reading" abzzy]
} 0
test io-40.14 {POSIX open access modes: RDWR} -match regexp -body {
file delete $path(test3)
open $path(test3) RDWR
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test io-40.15 {POSIX open access modes: RDWR} {
makeFile xyzzy test3
set f [open $path(test3) RDWR]
puts -nonewline $f "ab"
seek $f 0 current
set x [gets $f]
close $f
lappend x [viewFile test3]
} {zzy abzzy}
if {![file exists ~/_test_] && [file writable ~]} {
test io-40.16 {tilde substitution in open} -setup {
makeFile {Some text} _test_ ~
} -body {
file exists [file join $env(HOME) _test_]
} -cleanup {
removeFile _test_ ~
} -result 1
}
test io-40.17 {tilde substitution in open} {
set home $env(HOME)
unset env(HOME)
set x [list [catch {open ~/foo} msg] $msg]
set env(HOME) $home
set x
} {1 {couldn't find HOME environment variable to expand path}}
test io-41.1 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
test io-41.2 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent foo bar baz q} msg] $msg
} {1 {wrong # args: should be "fileevent channelId event ?script?"}}
test io-41.3 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp readable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.4 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp writable} msg] $msg
} {1 {can not find channel named "gorp"}}
test io-41.5 {Tcl_FileeventCmd: errors} {fileevent} {
list [catch {fileevent gorp who-knows} msg] $msg
} {1 {bad event name "who-knows": must be readable or writable}}
#
# Test fileevent on a file
#
set path(foo) [makeFile {} foo]
set f [open $path(foo) w+]
test io-42.1 {Tcl_FileeventCmd: creating, deleting, querying} {fileevent} {
list [fileevent $f readable] [fileevent $f writable]
} {{} {}}
test io-42.2 {Tcl_FileeventCmd: replacing} {fileevent} {
set result {}
fileevent $f r "first script"
lappend result [fileevent $f readable]
fileevent $f r "new script"
lappend result [fileevent $f readable]
fileevent $f r "yet another"
lappend result [fileevent $f readable]
fileevent $f r ""
lappend result [fileevent $f readable]
} {{first script} {new script} {yet another} {}}
test io-42.3 {Tcl_FileeventCmd: replacing, with NULL chars in script} {fileevent} {
set result {}
fileevent $f r "first scr\0ipt"
lappend result [string length [fileevent $f readable]]
fileevent $f r "new scr\0ipt"
lappend result [string length [fileevent $f readable]]
fileevent $f r "yet ano\0ther"
lappend result [string length [fileevent $f readable]]
fileevent $f r ""
lappend result [fileevent $f readable]
} {13 11 12 {}}
test io-43.1 {Tcl_FileeventCmd: creating, deleting, querying} {stdio unixExecs fileevent} {
set result {}
fileevent $f readable "script 1"
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable "write script"
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f readable {}
lappend result [fileevent $f readable] [fileevent $f writable]
fileevent $f writable {}
lappend result [fileevent $f readable] [fileevent $f writable]
} {{script 1} {} {script 1} {write script} {} {write script} {} {}}
test io-43.2 {Tcl_FileeventCmd: deleting when many present} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
set result {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r "read f"
fileevent $f2 r "read f2"
fileevent $f3 r "read f3"
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f2 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f3 r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
fileevent $f r {}
lappend result [fileevent $f r] [fileevent $f2 r] [fileevent $f3 r]
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {{} {} {} {read f} {read f2} {read f3} {read f} {} {read f3} {read f} {} {} {} {} {}}
test io-44.1 {FileEventProc procedure: normal read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
fileevent $f2 readable [namespace code {
set x [gets $f2]; fileevent $f2 readable {}
}]
puts $f2 text; flush $f2
variable x initial
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {text}
test io-44.2 {FileEventProc procedure: error in read event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
proc ::bgerror args "set [namespace which -variable x] \$args"
fileevent $f2 readable {error bogus}
puts $f2 text; flush $f2
variable x initial
vwait [namespace which -variable x]
rename ::bgerror {}
list $x [fileevent $f2 readable]
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {bogus {}}
test io-44.3 {FileEventProc procedure: normal write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
fileevent $f2 writable [namespace code {
lappend x "triggered"
incr count -1
if {$count <= 0} {
fileevent $f2 writable {}
}
}]
variable x initial
set count 3
vwait [namespace which -variable x]
vwait [namespace which -variable x]
vwait [namespace which -variable x]
set x
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {initial triggered triggered triggered}
test io-44.4 {FileEventProc procedure: eror in write event} -setup {
set f2 [open "|[list cat -u]" r+]
set f3 [open "|[list cat -u]" r+]
} -constraints {stdio unixExecs fileevent openpipe} -body {
proc ::bgerror args "set [namespace which -variable x] \$args"
fileevent $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
rename ::bgerror {}
list $x [fileevent $f2 writable]
} -cleanup {
catch {close $f2}
catch {close $f3}
} -result {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs openpipe fileevent} {
set f4 [open "|[list [interpreter] $path(cat) << foo]" r]
fileevent $f4 readable [namespace code {
if {[gets $f4 line] < 0} {
lappend x eof
fileevent $f4 readable {}
} else {
lappend x $line
}
}]
variable x initial
vwait [namespace which -variable x]
vwait [namespace which -variable x]
close $f4
set x
} {initial foo eof}
close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "binding triggered: \"[gets $f]\""
fileevent $f readable {}
}]
close $f
set x initial
after 100 [namespace code { set y done }]
variable y
vwait [namespace which -variable y]
set x
} {initial}
test io-45.2 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
fileevent $f readable [namespace code {
lappend x "f triggered: \"[gets $f]\""
fileevent $f readable {}
}]
fileevent $f2 readable [namespace code {
lappend x "f2 triggered: \"[gets $f2]\""
fileevent $f2 readable {}
}]
close $f
variable x initial
vwait [namespace which -variable x]
close $f2
set x
} {initial {f2 triggered: "foo bar"}}
test io-45.3 {DeleteFileEvent, cleanup on close} {fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
fileevent $f readable {f script}
fileevent $f2 readable {f2 script}
fileevent $f3 readable {f3 script}
set x {}
|
| ︙ | ︙ | |||
5524 5525 5526 5527 5528 5529 5530 |
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
testConstraint testfevent [llength [info commands testfevent]]
| | | | > | | 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 |
[catch {fileevent $f2 readable}] \
[catch {fileevent $f3 readable}]
} {0 {f script} 1 0 {f3 script} 0 {f script} 1 1 1 1 1}
# Execute these tests only if the "testfevent" command is present.
testConstraint testfevent [llength [info commands testfevent]]
test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} {
testfevent create
set script "set f \[[list open $path(foo) r]]\n"
append script {
set x "no event"
fileevent $f readable [namespace code {
set x "f triggered: [gets $f]"
fileevent $f readable {}
}]
}
testfevent cmd $script
after 1 ;# We must delay because Windows takes a little time to notice
update
testfevent cmd {close $f}
list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
testfevent create
|
| ︙ | ︙ | |||
5562 5563 5564 5565 5566 5567 5568 |
update idletasks
lappend result $x
update
lappend result $x
}
} {0 0 {0 timer}}
| | | | | | | | | 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 |
update idletasks
lappend result $x
update
lappend result $x
}
} {0 0 {0 timer}}
test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
fileevent $f readable {script 1}
testfevent create
testfevent share $f2
testfevent cmd "fileevent $f2 readable {script 2}"
fileevent $f3 readable {sript 3}
set x {}
lappend x [fileevent $f2 readable]
testfevent delete
lappend x [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable]
close $f
close $f2
close $f3
set x
} {{} {script 1} {} {sript 3}}
test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set f4 [open $path(foo) r]
fileevent $f readable {script 1}
testfevent create
testfevent share $f2
testfevent share $f3
testfevent cmd "fileevent $f2 readable {script 2}
fileevent $f3 readable {script 3}"
fileevent $f4 readable {script 4}
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable] [fileevent $f4 readable]]
close $f
close $f2
close $f3
close $f4
set x
} {{script 1} {} {} {script 4}}
test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
set f3 [open $path(foo) r]
set f4 [open $path(foo) r]
testfevent create
testfevent share $f3
testfevent share $f4
fileevent $f readable {script 1}
fileevent $f2 readable {script 2}
testfevent cmd "fileevent $f3 readable {script 3}
fileevent $f4 readable {script 4}"
testfevent delete
set x [list [fileevent $f readable] [fileevent $f2 readable] \
[fileevent $f3 readable] [fileevent $f4 readable]]
close $f
close $f2
close $f3
close $f4
set x
} {{script 1} {script 2} {} {}}
test io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent} {
set f [open $path(foo) r]
set f2 [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
fileevent $f readable {script 2}
fileevent $f2 readable {script 3}
set x [list [fileevent $f2 readable] \
[testfevent cmd "fileevent $f readable"] \
[fileevent $f readable]]
testfevent delete
close $f
close $f2
set x
} {{script 3} {script 1} {script 2}}
test io-47.5 {file events on shared files, deleting file events} {testfevent fileevent} {
set f [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
fileevent $f readable {script 2}
testfevent cmd "fileevent $f readable {}"
set x [list [testfevent cmd "fileevent $f readable"] \
[fileevent $f readable]]
testfevent delete
close $f
set x
} {{} {script 2}}
test io-47.6 {file events on shared files, deleting file events} {testfevent fileevent} {
set f [open $path(foo) r]
testfevent create
testfevent share $f
testfevent cmd "fileevent $f readable {script 1}"
fileevent $f readable {script 2}
fileevent $f readable {}
set x [list [testfevent cmd "fileevent $f readable"] \
[fileevent $f readable]]
testfevent delete
close $f
set x
} {{script 1} {}}
set path(bar) [makeFile {} bar]
test io-48.1 {testing readability conditions} {fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
|
| ︙ | ︙ | |||
5694 5695 5696 5697 5698 5699 5700 |
}
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
| | | 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 |
}
}
set l ""
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
test io-48.2 {testing readability conditions} {nonBlockFiles fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
|
| ︙ | ︙ | |||
5724 5725 5726 5727 5728 5729 5730 |
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
| | | 5809 5810 5811 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 |
variable x not_done
vwait [namespace which -variable x]
list $x $l
} {done {called called called called called called called}}
set path(my_script) [makeFile {} my_script]
test io-48.3 {testing readability conditions} {stdio unixOnly nonBlockFiles openpipe fileevent} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
|
| ︙ | ︙ | |||
5761 5762 5763 5764 5765 5766 5767 |
lappend l [fblocked $f]
gets $f
lappend l [fblocked $f]
}
}
set l ""
variable x not_done
| | | | | | | 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 |
lappend l [fblocked $f]
gets $f
lappend l [fblocked $f]
}
}
set l ""
variable x not_done
puts $f [list source $path(my_script)]
puts $f "set f \[[list open $path(bar) r]]"
puts $f {copy_slowly $f}
puts $f {exit}
vwait [namespace which -variable x]
close $f
list $x $l
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
variable c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
variable c
variable x
if {[eof $f]} {
|
| ︙ | ︙ | |||
5797 5798 5799 5800 5801 5802 5803 |
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 |
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.5 {lf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
|
| ︙ | ︙ | |||
5825 5826 5827 5828 5829 5830 5831 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.6 {cr write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
|
| ︙ | ︙ | |||
5853 5854 5855 5856 5857 5858 5859 |
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 |
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.7 {cr write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
|
| ︙ | ︙ | |||
5881 5882 5883 5884 5885 5886 5887 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.8 {crlf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
|
| ︙ | ︙ | |||
5909 5910 5911 5912 5913 5914 5915 |
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 |
set f [open $path(test1) r]
fconfigure $f -translation auto -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.9 {crlf write, testing readability, ^Z in middle, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
|
| ︙ | ︙ | |||
5937 5938 5939 5940 5941 5942 5943 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation auto
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.10 {lf write, testing readability, ^Z in middle, lf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
|
| ︙ | ︙ | |||
5965 5966 5967 5968 5969 5970 5971 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation lf
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation lf
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.11 {lf write, testing readability, ^Z termination, lf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
|
| ︙ | ︙ | |||
5993 5994 5995 5996 5997 5998 5999 |
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 |
set f [open $path(test1) r]
fconfigure $f -translation lf -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.12 {cr write, testing readability, ^Z in middle, cr read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable l
|
| ︙ | ︙ | |||
6021 6022 6023 6024 6025 6026 6027 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation cr
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation cr
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.13 {cr write, testing readability, ^Z termination, cr read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation cr
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable c
|
| ︙ | ︙ | |||
6049 6050 6051 6052 6053 6054 6055 |
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 |
set f [open $path(test1) r]
fconfigure $f -translation cr -eofchar \x1a
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.14 {crlf write, testing readability, ^Z in middle, crlf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%cfoo\nbar\n" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable c
|
| ︙ | ︙ | |||
6077 6078 6079 6080 6081 6082 6083 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation crlf
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
| | | | 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 |
set f [open $path(test1) r]
fconfigure $f -eofchar \x1a -translation crlf
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-48.15 {crlf write, testing readability, ^Z termi, crlf read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation crlf
set c [format "abc\ndef\n%c" 26]
puts -nonewline $f $c
close $f
proc consume {f} {
variable c
|
| ︙ | ︙ | |||
6107 6108 6109 6110 6111 6112 6113 |
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-49.1 {testing crlf reading, leftover cr disgorgment} {
| | | 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 |
fileevent $f readable [namespace code [list consume $f]]
variable x
vwait [namespace which -variable x]
list $c $l
} {3 {abc def {}}}
test io-49.1 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
|
| ︙ | ︙ | |||
6136 6137 6138 6139 6140 6141 6142 |
lappend l [read $f 1]
lappend l [eof $f]
close $f
set l
} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 {
} 7 0 {} 1"
test io-49.2 {testing crlf reading, leftover cr disgorgment} {
| | | 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 |
lappend l [read $f 1]
lappend l [eof $f]
close $f
set l
} "7 a 1 [list \r] 2 b 3 [list \r] 4 c 5 {
} 7 0 {} 1"
test io-49.2 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
|
| ︙ | ︙ | |||
6159 6160 6161 6162 6163 6164 6165 |
lappend l [read $f 2]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
test io-49.3 {testing crlf reading, leftover cr disgorgment} {
| | | | | | | | 6244 6245 6246 6247 6248 6249 6250 6251 6252 6253 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 |
lappend l [read $f 2]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\r] 2 [list b\r] 4 [list c\n] 7 0 {} 7 1"
test io-49.3 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 3]
lappend l [tell $f]
lappend l [read $f 3]
lappend l [tell $f]
lappend l [eof $f]
lappend l [read $f 3]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\rb] 3 [list \rc\n] 7 0 {} 7 1"
test io-49.4 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [read $f 3]
lappend l [tell $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} "7 [list a\rb] 3 [list \rc] 7 0 {} 7 1"
test io-49.5 {testing crlf reading, leftover cr disgorgment} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\rb\rc\r\n"
close $f
set f [open $path(test1) r]
set l ""
lappend l [file size $path(test1)]
fconfigure $f -translation crlf
lappend l [set x [gets $f]]
lappend l [tell $f]
lappend l [gets $f]
lappend l [tell $f]
lappend l [eof $f]
close $f
set l
} [list 7 a\rb\rc 7 {} 7 1]
testConstraint testchannelevent [llength [info commands testchannelevent]]
test io-50.1 {testing handler deletion} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f]]
proc delhandler {f} {
variable z
set z called
testchannelevent $f delete 0
}
set z not_called
update
close $f
set z
} called
test io-50.2 {testing handler deletion with multiple handlers} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delhandler $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
proc delhandler {f i} {
variable z
lappend z "called delhandler $f $i"
testchannelevent $f delete 0
}
set z ""
update
close $f
string compare [string tolower $z] \
[list [list called delhandler $f 0] [list called delhandler $f 1]]
} 0
test io-50.3 {testing handler deletion with multiple handlers} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f 1]]
testchannelevent $f add readable [namespace code [list delhandler $f 0]]
set z ""
proc notcalled {f i} {
|
| ︙ | ︙ | |||
6281 6282 6283 6284 6285 6286 6287 |
update
close $f
string compare [string tolower $z] \
[list [list delhandler $f 0 called] \
[list delhandler $f 0 deleted myself]]
} 0
test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
| | | 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 |
update
close $f
string compare [string tolower $z] \
[list [list delhandler $f 0 called] \
[list delhandler $f 0 deleted myself]]
} 0
test io-50.4 {testing handler deletion vs reentrant calls} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list delrecursive $f]]
proc delrecursive {f} {
variable z
variable u
|
| ︙ | ︙ | |||
6306 6307 6308 6309 6310 6311 6312 |
set z ""
update
close $f
string compare [string tolower $z] \
{{delrecursive calling recursive} {delrecursive deleting recursive}}
} 0
test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
| | | 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 |
set z ""
update
close $f
string compare [string tolower $z] \
{{delrecursive calling recursive} {delrecursive deleting recursive}}
} 0
test io-50.5 {testing handler deletion vs reentrant calls} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list notcalled $f]]
testchannelevent $f add readable [namespace code [list del $f]]
proc notcalled {f} {
variable z
|
| ︙ | ︙ | |||
6340 6341 6342 6343 6344 6345 6346 |
update
close $f
string compare [string tolower $z] \
[list {del calling recursive} {del deleted notcalled} \
{del deleted myself} {del after update}]
} 0
test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
| | | 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 |
update
close $f
string compare [string tolower $z] \
[list {del calling recursive} {del deleted notcalled} \
{del deleted myself} {del after update}]
} 0
test io-50.6 {testing handler deletion vs reentrant calls} {testchannelevent} {
file delete $path(test1)
set f [open $path(test1) w]
close $f
set f [open $path(test1) r]
testchannelevent $f add readable [namespace code [list second $f]]
testchannelevent $f add readable [namespace code [list first $f]]
proc first {f} {
variable u
|
| ︙ | ︙ | |||
6422 6423 6424 6425 6426 6427 6428 |
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
close $ss
set result
} {sock1 sock2 sock3 sock4}
| | | | | | | | | | | | | | | | | | | 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 |
vwait [namespace which -variable wait]
lappend result [gets $cs]
close $cs
close $ss
set result
} {sock1 sock2 sock3 sock4}
test io-52.1 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fcopy $f1 $f2 -command { # }
catch { fcopy $f1 $f2 } msg
close $f1
close $f2
string compare $msg "channel \"$f1\" is busy"
} {0}
test io-52.2 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
set f3 [open $thisScript]
fcopy $f1 $f2 -command { # }
catch { fcopy $f3 $f2 } msg
close $f1
close $f2
close $f3
string compare $msg "channel \"$f2\" is busy"
} {0}
test io-52.3 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
set s0 [fcopy $f1 $f2]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.4 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -size 40
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
lappend result [file size $path(test1)]
} {0 0 40}
test io-52.5 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2 -size -1
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.6 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
set s0 [fcopy $f1 $f2 -size [expr [file size $thisScript] + 5]]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.7 {TclCopyChannel} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation lf -blocking 0
fcopy $f1 $f2
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
close $f1
close $f2
if {"$s1" == "$s2"} {
lappend result ok
}
set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio openpipe fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
fconfigure $f1 -translation lf
puts $f1 "
puts ready
gets stdin
set f1 \[open [list $thisScript] r\]
fconfigure \$f1 -translation lf
|
| ︙ | ︙ | |||
6562 6563 6564 6565 6566 6567 6568 | # Create kyrillic file, use lf translation to avoid os eol issues set out [open $path(kyrillic.txt) w] fconfigure $out -encoding koi8-r -translation lf puts $out "\u0410\u0410" close $out | | | 6647 6648 6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 |
# Create kyrillic file, use lf translation to avoid os eol issues
set out [open $path(kyrillic.txt) w]
fconfigure $out -encoding koi8-r -translation lf
puts $out "\u0410\u0410"
close $out
test io-52.9 {TclCopyChannel & encodings} {fcopy} {
# Copy kyrillic to UTF-8, using fcopy.
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
fconfigure $in -encoding koi8-r -translation lf
fconfigure $out -encoding utf-8 -translation lf
|
| ︙ | ︙ | |||
6593 6594 6595 6596 6597 6598 6599 |
close $out
list [file size $path(kyrillic.txt)] \
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
| | | < | | | | | | | | | > > < > | | | | 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 |
close $out
list [file size $path(kyrillic.txt)] \
[file size $path(utf8-fcopy.txt)] \
[file size $path(utf8-rp.txt)]
} {3 5 5}
test io-52.10 {TclCopyChannel & encodings} {fcopy} {
# encoding to binary (=> implies that the
# internal utf-8 is written)
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-fcopy.txt) w]
fconfigure $in -encoding koi8-r -translation lf
# -translation binary is also -encoding binary
fconfigure $out -translation binary
fcopy $in $out
close $in
close $out
file size $path(utf8-fcopy.txt)
} 5
test io-52.11 {TclCopyChannel & encodings} {fcopy} {
# binary to encoding => the input has to be
# in utf-8 to make sense to the encoder
set in [open $path(utf8-fcopy.txt) r]
set out [open $path(kyrillic.txt) w]
# -translation binary is also -encoding binary
fconfigure $in -translation binary
fconfigure $out -encoding koi8-r -translation lf
fcopy $in $out
close $in
close $out
file size $path(kyrillic.txt)
} 3
test io-53.1 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -size 0
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
close $f1
close $f2
lappend result [file size $path(test1)]
} {0 0 0}
test io-53.2 {CopyData} {fcopy} {
file delete $path(test1)
set f1 [open $thisScript]
set f2 [open $path(test1) w]
fconfigure $f1 -translation lf -blocking 0
fconfigure $f2 -translation cr -blocking 0
fcopy $f1 $f2 -command [namespace code {set s0}]
set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
variable s0
vwait [namespace which -variable s0]
close $f1
close $f2
set s1 [file size $thisScript]
set s2 [file size $path(test1)]
if {("$s1" == "$s2") && ($s0 == $s1)} {
lappend result ok
}
set result
} {0 0 ok}
test io-53.3 {CopyData: background read underflow} {stdio unixOnly openpipe fcopy} {
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts -nonewline $f1 {
puts ready
flush stdout ;# Don't assume line buffered!
fcopy stdin stdout -command { set x }
vwait x
set f [}
puts $f1 [list open $path(test1) w]]
puts $f1 {
fconfigure $f -translation lf
puts $f "done"
close $f
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set result [gets $f1]
puts $f1 line1
flush $f1
lappend result [gets $f1]
puts $f1 line2
flush $f1
lappend result [gets $f1]
close $f1
after 500
set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio unixOnly openpipe fileevent fcopy} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(test1)
file delete $path(pipe)
set f1 [open $path(pipe) w]
puts $f1 {
puts ready
fcopy stdin stdout -command { set x }
vwait x
set f [open $path(test1) w]
fconfigure $f -translation lf
|
| ︙ | ︙ | |||
6742 6743 6744 6745 6746 6747 6748 |
if {[string length $error]} {
set fcopyTestDone 1
} else {
set fcopyTestDone 0
}
}
| | | | | | 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 |
if {[string length $error]} {
set fcopyTestDone 1
} else {
set fcopyTestDone 0
}
}
test io-53.5 {CopyData: error during fcopy} {socket fcopy} {
variable fcopyTestDone
set listen [socket -server [namespace code FcopyTestAccept] 0]
set in [open $thisScript] ;# 126 K
set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
fcopy $in $out -command [namespace code FcopyTestDone]
variable fcopyTestDone
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone] ;# The error occurs here in the b.g.
}
close $in
close $out
set fcopyTestDone ;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio openpipe fcopy} {
variable fcopyTestDone
file delete $path(pipe)
file delete $path(test1)
catch {unset fcopyTestDone}
set f1 [open $path(pipe) w]
puts $f1 "exit 1"
close $f1
set in [open "|[list [interpreter] $path(pipe)]" r+]
set out [open $path(test1) w]
fcopy $in $out -command [namespace code FcopyTestDone]
|
| ︙ | ︙ | |||
6795 6796 6797 6798 6799 6800 6801 |
after 100 [list
fcopy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]
]
}
}
| | | < | 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 |
after 100 [list
fcopy $in $out -size 1000 \
-command [namespace code [list doFcopy $in $out]]
]
}
}
test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} {
variable fcopyTestDone
file delete $path(pipe)
catch {unset fcopyTestDone}
set fcopyTestCount 0
set f1 [open $path(pipe) w]
puts $f1 {
# Write 10 bytes / 10 msec
proc Write {count} {
puts -nonewline "1234567890"
|
| ︙ | ︙ | |||
6831 6832 6833 6834 6835 6836 6837 |
}
catch {close $in}
close $out
# -1=error 0=script error N=number of bytes
expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1
} {3450}
| | | 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 |
}
catch {close $in}
close $out
# -1=error 0=script error N=number of bytes
expr ($fcopyTestDone == 0) ? $fcopyTestCount : -1
} {3450}
test io-54.1 {Recursive channel events} {socket fileevent} {
# This test checks to see if file events are delivered during recursive
# event loops when there is buffered data on the channel.
proc accept {s a p} {
variable as
fconfigure $s -translation lf
puts $s "line 1\nline2\nline3"
|
| ︙ | ︙ | |||
6885 6886 6887 6888 6889 6890 6891 |
vwait [namespace which -variable x]
after cancel $a
close $as
close $ss
close $cs
list $result $x
} {{{line 1} 1 2} 2}
| | | 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 |
vwait [namespace which -variable x]
after cancel $a
close $as
close $ss
close $cs
list $result $x
} {{{line 1} 1 2} 2}
test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileevent} {
set accept {}
set after {}
variable s [socket -server [namespace code accept] 0]
proc accept {s a p} {
variable counter
variable accept
|
| ︙ | ︙ | |||
6947 6948 6949 6950 6951 6952 6953 |
after cancel $after
if {$accept != {}} {close $accept}
set counter
} 1
set path(fooBar) [makeFile {} fooBar]
| | | 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 |
after cancel $after
if {$accept != {}} {close $accept}
set counter
} 1
set path(fooBar) [makeFile {} fooBar]
test io-55.1 {ChannelEventScriptInvoker: deletion} {fileevent} {
variable x
proc eventScript {fd} {
variable x
close $fd
error "planned error"
set x whoops
}
|
| ︙ | ︙ | |||
6984 6985 6986 6987 6988 6989 6990 |
after idle [namespace code {set y done}]
variable y
vwait [namespace which -variable y]
close $f
lappend result $y
} {2 done}
| | | 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 |
after idle [namespace code {set y done}]
variable y
vwait [namespace which -variable y]
close $f
lappend result $y
} {2 done}
test io-57.1 {buffered data and file events, gets} {fileevent} {
proc accept {sock args} {
variable s2
set s2 $sock
}
set server [socket -server [namespace code accept] 0]
set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
variable s2
|
| ︙ | ︙ | |||
7007 7008 7009 7010 7011 7012 7013 |
lappend result [gets $s2]
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {12 readable 34567890 timer}
| | | 7092 7093 7094 7095 7096 7097 7098 7099 7100 7101 7102 7103 7104 7105 7106 |
lappend result [gets $s2]
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {12 readable 34567890 timer}
test io-57.2 {buffered data and file events, read} {fileevent} {
proc accept {sock args} {
variable s2
set s2 $sock
}
set server [socket -server [namespace code accept] 0]
set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
variable s2
|
| ︙ | ︙ | |||
7031 7032 7033 7034 7035 7036 7037 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
| | | 7116 7117 7118 7119 7120 7121 7122 7123 7124 7125 7126 7127 7128 7129 7130 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} {
set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
|
| ︙ | ︙ | |||
7074 7075 7076 7077 7078 7079 7080 |
set f [open $path(longfile) r]
set result [testchannel mthread $f]
close $f
string equal $result [testmainthread]
} {1}
| | | 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 |
set f [open $path(longfile) r]
set result [testchannel mthread $f]
close $f
string equal $result [testmainthread]
} {1}
test io-60.1 {writing illegal utf sequences} {openpipe fileevent} {
# This test will hang in older revisions of the core.
set out [open $path(script) w]
puts $out {
puts [encoding convertfrom identity \xe2]
exit 1
}
|
| ︙ | ︙ | |||
7105 7106 7107 7108 7109 7110 7111 |
vwait [namespace which -variable x]
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
} {1 {gets {} catch {error writing "stdout": invalid argument}}}
| | | > > > > > > > > > > > > > > > > > > > > > > > > | | 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 |
vwait [namespace which -variable x]
# cut of the remainder of the error stack, especially the filename
set result [lreplace $result 3 3 [lindex [split [lindex $result 3] \n] 0]]
list $x $result
} {1 {gets {} catch {error writing "stdout": invalid argument}}}
test io-61.1 {Reset eof state after changing the eof char} -setup {
set datafile [makeFile {} eofchar]
set f [open $datafile w]
fconfigure $f -translation binary
puts -nonewline $f [string repeat "Ho hum\n" 11]
puts $f =
set line [string repeat "Ge gla " 4]
puts -nonewline $f [string repeat [string trimright $line]\n 834]
close $f
} -body {
set f [open $datafile r]
fconfigure $f -eofchar =
set res {}
lappend res [read $f; tell $f]
fconfigure $f -eofchar {}
lappend res [read $f 1]
lappend res [read $f; tell $f]
# Any seek zaps the internals into a good state.
#seek $f 0 start
#seek $f 0 current
#lappend res [read $f; tell $f]
close $f
set res
} -cleanup {
removeFile eofchar
} -result {77 = 23431}
# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return
|
Changes to tests/ioCmd.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, # fblocked, fconfigure, open, channel, fcopy # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | > | | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# -*- tcl -*-
# Commands covered: open, close, gets, read, puts, seek, tell, eof, flush,
# fblocked, fconfigure, open, channel, fcopy
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: ioCmd.test,v 1.16.2.3 2006/03/16 18:23:24 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint fcopy [llength [info commands fcopy]]
test iocmd-1.1 {puts command} {
list [catch {puts} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
test iocmd-1.2 {puts command} {
list [catch {puts a b c d e f g} msg] $msg
} {1 {wrong # args: should be "puts ?-nonewline? ?channelId? string"}}
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
test iocmd-4.6 {read command} {
list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.8 {read command with incorrect combination of arguments} {
| | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
test iocmd-4.6 {read command} {
list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.7 {read command} {
list [catch {read -nonewline stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-4.8 {read command with incorrect combination of arguments} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1)]
set x [list [catch {read -nonewline $f 20 z} msg] $msg $errorCode]
close $f
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
test iocmd-8.2 {fconfigure command} {
list [catch {fconfigure a b c d e f} msg] $msg
} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}}
test iocmd-8.3 {fconfigure command} {
list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
test iocmd-8.4 {fconfigure command} {
| | | | | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
test iocmd-8.2 {fconfigure command} {
list [catch {fconfigure a b c d e f} msg] $msg
} {1 {wrong # args: should be "fconfigure channelId ?optionName? ?value? ?optionName value?..."}}
test iocmd-8.3 {fconfigure command} {
list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
test iocmd-8.4 {fconfigure command} {
file delete $path(test1)
set f1 [open $path(test1) w]
set x [list [catch {fconfigure $f1 froboz} msg] $msg]
close $f1
set x
} {1 {bad option "froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.5 {fconfigure command} {
list [catch {fconfigure stdin -buffering froboz} msg] $msg
} {1 {bad value for -buffering: must be one of full, line, or none}}
test iocmd-8.6 {fconfigure command} {
list [catch {fconfigure stdin -translation froboz} msg] $msg
} {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}}
test iocmd-8.7 {fconfigure command} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {} -encoding unicode
set x [fconfigure $f1]
close $f1
set x
} {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf}
test iocmd-8.8 {fconfigure command} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
-eofchar {} -encoding unicode
set x ""
lappend x [fconfigure $f1 -buffering]
lappend x [fconfigure $f1]
close $f1
set x
} {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}}
test iocmd-8.9 {fconfigure command} {
file delete $path(test1)
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
-eofchar {} -encoding binary
set x [fconfigure $f1]
close $f1
set x
} {-blocking 1 -buffering none -buffersize 4040 -encoding binary -eofchar {} -translation lf}
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 |
test iocmd-10.5 {fblocked command} {
fblocked stdin
} 0
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
| | | | | | < < | | | | < < | | | | | < < | > | 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
test iocmd-10.5 {fblocked command} {
fblocked stdin
} 0
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
file delete $path(test5)
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
set f [open $path(test4) w]
close $f
list [catch {open "| cat < $path(test4) > $path(test5)" w} msg] $msg $errorCode
} {1 {can't write input to command: standard input was redirected} NONE}
test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > $path(test5)" r} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
list [catch {open "| echo > $path(test5)" r+} msg] $msg $errorCode
} {1 {can't read output from command: standard output was redirected} NONE}
test iocmd-12.1 {POSIX open access modes: RDONLY} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
puts $f "and this one"
close $f
set f [open $path(test1) RDONLY]
set x [list [gets $f] [catch {puts $f Test} msg] $msg]
close $f
string compare $x \
"{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]"
} 0
test iocmd-12.2 {POSIX open access modes: RDONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) RDONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test iocmd-12.3 {POSIX open access modes: WRONLY} -match regexp -body {
file delete $path(test3)
open $path(test3) WRONLY
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
#
# Test 13.4 relies on assigning the same channel name twice.
#
test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} {
file delete $path(test3)
set f [open $path(test3) w]
fconfigure $f -eofchar {}
puts $f xyzzy
close $f
set f [open $path(test3) WRONLY]
fconfigure $f -eofchar {}
puts -nonewline $f "ab"
seek $f 0 current
set x [list [catch {gets $f} msg] $msg]
close $f
set f [open $path(test3) r]
fconfigure $f -eofchar {}
lappend x [gets $f]
close $f
set y [list 1 [format "channel \"%s\" wasn't opened for reading" $f] abzzy]
string compare $x $y
} 0
test iocmd-12.5 {POSIX open access modes: RDWR} -match regexp -body {
file delete $path(test3)
open $path(test3) RDWR
} -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory}
test iocmd-12.6 {POSIX open access modes: errors} {
concat [catch {open $path(test3) "FOO \{BAR BAZ"} msg] $msg\n$errorInfo
} "1 unmatched open brace in list
unmatched open brace in list
while processing open access modes \"FOO {BAR BAZ\"
invoked from within
\"open \$path(test3) \"FOO \\{BAR BAZ\"\""
test iocmd-12.7 {POSIX open access modes: errors} {
list [catch {open $path(test3) {FOO BAR BAZ}} msg] $msg
} {1 {invalid access mode "FOO": must be RDONLY, WRONLY, RDWR, APPEND, CREAT EXCL, NOCTTY, NONBLOCK, or TRUNC}}
test iocmd-12.8 {POSIX open access modes: errors} {
list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg
} {1 {access mode must include either RDONLY, WRONLY, or RDWR}}
close [open $path(test3) w]
test iocmd-13.1 {errors in open command} {
list [catch {open} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
test iocmd-13.2 {errors in open command} {
list [catch {open a b c d} msg] $msg
} {1 {wrong # args: should be "open fileName ?access? ?permissions?"}}
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
list [catch {open $path(test1) r+1} msg] $msg
} {1 {illegal access mode "r+1"}}
test iocmd-13.6 {errors in open command} {
set msg [list [catch {open _non_existent_} msg] $msg $errorCode]
regsub [file join {} _non_existent_] $msg "_non_existent_" msg
string tolower $msg
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
test iocmd-14.1 {file id parsing errors} {
list [catch {eof gorp} msg] $msg $errorCode
} {1 {can not find channel named "gorp"} NONE}
test iocmd-14.2 {file id parsing errors} {
list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 |
list [catch {open $path(test1) r+1} msg] $msg
} {1 {illegal access mode "r+1"}}
test iocmd-13.6 {errors in open command} {
set msg [list [catch {open _non_existent_} msg] $msg $errorCode]
regsub [file join {} _non_existent_] $msg "_non_existent_" msg
string tolower $msg
} {1 {couldn't open "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}}
test iocmd-13.7.1 {open for append, a mode} -setup {
set log [makeFile {} out]
set chans {}
} -body {
foreach i { 0 1 2 3 4 5 6 7 8 9 } {
puts [set ch [open $log a]] $i
lappend chans $ch
}
foreach ch $chans {catch {close $ch}}
lsort [split [string trim [viewFile out]] \n]
} -cleanup {
removeFile out
# Ensure that channels are gone, even if body failed to do so
foreach ch $chans {catch {close $ch}}
} -result {0 1 2 3 4 5 6 7 8 9}
test iocmd-13.7.2 {open for append, O_APPEND} -setup {
set log [makeFile {} out]
set chans {}
} -body {
foreach i { 0 1 2 3 4 5 6 7 8 9 } {
puts [set ch [open $log {WRONLY CREAT APPEND}]] $i
lappend chans $ch
}
foreach ch $chans {catch {close $ch}}
lsort [split [string trim [viewFile out]] \n]
} -cleanup {
removeFile out
# Ensure that channels are gone, even if body failed to do so
foreach ch $chans {catch {close $ch}}
} -result {0 1 2 3 4 5 6 7 8 9}
test iocmd-14.1 {file id parsing errors} {
list [catch {eof gorp} msg] $msg $errorCode
} {1 {can not find channel named "gorp"} NONE}
test iocmd-14.2 {file id parsing errors} {
list [catch {eof filex} msg] $msg
} {1 {can not find channel named "filex"}}
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
close $f
set expect "1 {can not find channel named \"$f\"}"
test iocmd-14.10 {file id parsing errors} {
list [catch {eof $f} msg] $msg
} $expect
| | | | | | | | | | | | | | | | | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 |
close $f
set expect "1 {can not find channel named \"$f\"}"
test iocmd-14.10 {file id parsing errors} {
list [catch {eof $f} msg] $msg
} $expect
test iocmd-15.1 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.2 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy 1} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.3 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.4 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy 1 2 3} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.5 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy 1 2 3 4 5} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
set path(test2) [makeFile {} test2]
set f [open $path(test1) w]
close $f
set rfile [open $path(test1) r]
set wfile [open $path(test2) w]
test iocmd-15.6 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy foo $wfile} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.7 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile foo} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.8 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $wfile $wfile} msg] $msg
} "1 {channel \"$wfile\" wasn't opened for reading}"
test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $rfile} msg] $msg
} "1 {channel \"$rfile\" wasn't opened for writing}"
test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile foo bar} msg] $msg
} {1 {bad switch "foo": must be -size or -command}}
test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} {
list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg
} {1 {expected integer but got "foo"}}
close $rfile
close $wfile
# cleanup
foreach file [list test1 test2 test3 test4] {
removeFile $file
}
# delay long enough for background processes to finish
after 500
foreach file [list test5] {
removeFile $file
}
cleanupTests
return
|
Changes to tests/ioUtil.test.
1 2 3 4 5 6 7 8 9 10 | # This file (ioUtil.test) tests the hookable TclStat(), TclAccess(), # and Tcl_OpenFileChannel, routines in the file generic/tclIOUtils.c. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file (ioUtil.test) tests the hookable TclStat(), TclAccess(),
# and Tcl_OpenFileChannel, routines in the file generic/tclIOUtils.c.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: ioUtil.test,v 1.13.2.1 2003/04/14 15:45:57 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::testConstraint testopenfilechannelproc \
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
catch {teststatproc delete TestStatProc3} err11
list $err9 $err10 $err11
} {{"TestStatProc1": could not be deleteed} {"TestStatProc2": could not be deleteed} {"TestStatProc3": could not be deleteed}}
eval $unsetScript
| | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
catch {teststatproc delete TestStatProc3} err11
list $err9 $err10 $err11
} {{"TestStatProc1": could not be deleteed} {"TestStatProc2": could not be deleteed} {"TestStatProc3": could not be deleteed}}
eval $unsetScript
test ioUtil-1.9 {TclAccess: Check that none of the test procs are there.} {
catch {file exists testAccess1%.fil} err1
catch {file exists testAccess2%.fil} err2
catch {file exists testAccess3%.fil} err3
list $err1 $err2 $err3
} {0 0 0}
test ioUtil-1.10 {TclAccessInsertProc: Insert the 3 test TclAccess_ procedures.} {testaccessproc} {
catch {testaccessproc insert TclpAccess} err1
testaccessproc insert TestAccessProc1
testaccessproc insert TestAccessProc2
testaccessproc insert TestAccessProc3
set err1
} {bad arg "insert": must be TestAccessProc1, TestAccessProc2, or TestAccessProc3}
|
| ︙ | ︙ |
Changes to tests/iogt.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # -*- tcl -*- # Commands covered: transform, and stacking in general # # This file contains a collection of tests for Giot # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2000 Ajuba Solutions. # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# -*- tcl -*-
# Commands covered: transform, and stacking in general
#
# This file contains a collection of tests for Giot
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Copyright (c) 2000 Ajuba Solutions.
# Copyright (c) 2000 Andreas Kupries.
# All rights reserved.
#
# RCS: @(#) $Id: iogt.test,v 1.7.2.1 2005/04/14 07:10:57 davygrvy Exp $
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
namespace eval ::tcl::test::iogt {
|
| ︙ | ︙ | |||
494 495 496 497 498 499 500 |
set fout [open $path(dummyout) w]
set ain [list] ; set aout [list]
audit_ops ain -attach $fin
audit_ops aout -attach $fout
fconfigure $fin -buffersize 10
| | | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
set fout [open $path(dummyout) w]
set ain [list] ; set aout [list]
audit_ops ain -attach $fin
audit_ops aout -attach $fout
fconfigure $fin -buffersize 10
fconfigure $fout -buffersize 10
fcopy $fin $fout
close $fin
close $fout
set res "[join $ain \n]\n--------\n[join $aout \n]"
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 |
set fout [open $path(dummyout) w]
set ain [list] ; set aout [list]
audit_flow ain -attach $fin
audit_flow aout -attach $fout
fconfigure $fin -buffersize 10
| | | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
set fout [open $path(dummyout) w]
set ain [list] ; set aout [list]
audit_flow ain -attach $fin
audit_flow aout -attach $fout
fconfigure $fin -buffersize 10
fconfigure $fout -buffersize 10
fcopy $fin $fout
close $fin
close $fout
set res "[join $ain \n]\n--------\n[join $aout \n]"
|
| ︙ | ︙ |
Changes to tests/list.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: list # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: list
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: list.test,v 1.5.24.1 2003/03/27 13:11:15 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# First, a bunch of individual tests
|
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\
test list-1.23 {basic tests} {list \{} "\\{"
test list-1.24 {basic tests} {list} {}
# For the next round of tests create a list and then pick it apart
# with "index" to make sure that we get back exactly what went in.
| < < | | | < | < | < | | | | | | | | | | | | | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 |
test list-1.22 {basic tests} {list "{ab}\\"} \\{ab\\}\\\\
test list-1.23 {basic tests} {list \{} "\\{"
test list-1.24 {basic tests} {list} {}
# For the next round of tests create a list and then pick it apart
# with "index" to make sure that we get back exactly what went in.
set num 0
proc lcheck {testid a b c} {
global num d
set d [list $a $b $c]
test ${testid}-0 {what goes in must come out} {lindex $d 0} $a
test ${testid}-1 {what goes in must come out} {lindex $d 1} $b
test ${testid}-2 {what goes in must come out} {lindex $d 2} $c
}
lcheck list-2.1 a b c
lcheck list-2.2 "a b" c\td e\nf
lcheck list-2.3 {{a b}} {} { }
lcheck list-2.4 \$ \$ab ab\$
lcheck list-2.5 \; \;ab ab\;
lcheck list-2.6 \[ \[ab ab\[
lcheck list-2.7 \\ \\ab ab\\
lcheck list-2.8 {"} {"ab} {ab"} ;#" Stupid emacs highlighting!
lcheck list-2.9 {a b} { ab} {ab }
lcheck list-2.10 a{ a{b \{ab
lcheck list-2.11 a} a}b }ab
lcheck list-2.12 a\\} {a \}b} {a \{c}
lcheck list-2.13 xyz \\ 1\\\n2
lcheck list-2.14 "{ab}\\" "{ab}xy" abc
concat {}
# Check that tclListObj.c's SetListFromAny handles possible overlarge
# string rep lengths in the source object.
proc slowsort list {
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
test list-3.1 {SetListFromAny and lrange/concat results} {
slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}
# cleanup
::tcltest::cleanupTests
return
| < < < < < < < < < < < < | 104 105 106 107 108 109 110 |
test list-3.1 {SetListFromAny and lrange/concat results} {
slowsort {fred julie alex carol bill annie}
} {alex annie bill carol fred julie}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/load.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: load # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: load
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: load.test,v 1.11.2.1 2004/09/14 17:02:56 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Figure out what extension is used for shared libraries on this
|
| ︙ | ︙ | |||
74 75 76 77 78 79 80 |
interp create -safe child
test load-2.2 {loading into a safe interpreter, with package name conversion} \
[list $dll $loaded] {
load [file join $testDir pkgb$ext] pKgB child
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
[catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
| | > | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
interp create -safe child
test load-2.2 {loading into a safe interpreter, with package name conversion} \
[list $dll $loaded] {
load [file join $testDir pkgb$ext] pKgB child
list [child eval pkgb_sub 44 13] [catch {child eval pkgb_unsafe} msg] $msg \
[catch {pkgb_sub 12 10} msg2] $msg2
} {31 1 {invalid command name "pkgb_unsafe"} 1 {invalid command name "pkgb_sub"}}
test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded] \
-body {
list [catch {load [file join $testDir pkgc$ext] foo} msg] $msg
} -match glob -result {1 {*couldn't find procedure Foo_Init}}
test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
} {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}
test load-3.1 {error in _Init procedure, same interpreter} \
[list $dll $loaded] {
list [catch {load [file join $testDir pkge$ext] pkge} msg] \
|
| ︙ | ︙ |
Changes to tests/lsearch.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: lsearch # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: lsearch
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: lsearch.test,v 1.10.2.3 2005/12/09 14:39:25 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
set x {abcd bbcd 123 234 345}
|
| ︙ | ︙ | |||
289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
}
set res
} [concat -1 -1 [lrange $increasingIntegers 2 end]]
test lsearch-10.7 {offset searching with an empty list} {
# Stop bug #694232 from reocurring
lsearch -start 0 {} x
} -1
test lsearch-11.1 {negated searches} {
lsearch -not {a a a b a a a} a
} 3
test lsearch-11.2 {negated searches} {
lsearch -not {a a a a a a a} a
} -1
| > > > > > > > > > > > > | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 |
}
set res
} [concat -1 -1 [lrange $increasingIntegers 2 end]]
test lsearch-10.7 {offset searching with an empty list} {
# Stop bug #694232 from reocurring
lsearch -start 0 {} x
} -1
test lsearch-10.8 {offset searching past the end of the list} {
# Stop [Bug 1374778] from reoccurring
lsearch -start 10 {a b c} c
} -1
test lsearch-10.9 {offset searching past the end of the list} {
# Stop [Bug 1374778] from reoccurring
lsearch -start 10 -all {a b c} c
} {}
test lsearch-10.10 {offset searching past the end of the list} {
# Stop [Bug 1374778] from reoccurring
lsearch -start 10 -inline {a b c} c
} {}
test lsearch-11.1 {negated searches} {
lsearch -not {a a a b a a a} a
} 3
test lsearch-11.2 {negated searches} {
lsearch -not {a a a a a a a} a
} -1
|
| ︙ | ︙ | |||
311 312 313 314 315 316 317 |
test lsearch-13.1 {search for all matches} {
lsearch -all {a b a c a d} 1
} {}
test lsearch-13.2 {search for all matches} {
lsearch -all {a b a c a d} a
} {0 2 4}
| | | | | | | | | | | > > > > | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
test lsearch-13.1 {search for all matches} {
lsearch -all {a b a c a d} 1
} {}
test lsearch-13.2 {search for all matches} {
lsearch -all {a b a c a d} a
} {0 2 4}
test lsearch-14.1 {combinations: -all and -inline} {
lsearch -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
} {a1 a3 a5}
test lsearch-14.2 {combinations: -all, -inline and -not} {
lsearch -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {b2 c4 d6}
test lsearch-14.3 {combinations: -all and -not} {
lsearch -all -not -glob {a1 b2 a3 c4 a5 d6} a*
} {1 3 5}
test lsearch-14.4 {combinations: -inline and -not} {
lsearch -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {b2}
test lsearch-14.5 {combinations: -start, -all and -inline} {
lsearch -start 2 -all -inline -glob {a1 b2 a3 c4 a5 d6} a*
} {a3 a5}
test lsearch-14.6 {combinations: -start, -all, -inline and -not} {
lsearch -start 2 -all -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {c4 d6}
test lsearch-14.7 {combinations: -start, -all and -not} {
lsearch -start 2 -all -not -glob {a1 b2 a3 c4 a5 d6} a*
} {3 5}
test lsearch-14.8 {combinations: -start, -inline and -not} {
lsearch -start 2 -inline -not -glob {a1 b2 a3 c4 a5 d6} a*
} {c4}
test lsearch-15.1 {make sure no shimmering occurs} {
set x [expr int(sin(0))]
lsearch -start $x $x $x
} 0
test lsearch-16.1 {lsearch -regexp shared object} {
set str a
lsearch -regexp $str $str
} 0
# Bug 1366683
test lsearch-16.2 {lsearch -regexp allows internal backrefs} {
lsearch -regexp {a aa b} {(.)\1}
} 1
# cleanup
catch {unset res}
catch {unset increasingIntegers}
catch {unset decreasingIntegers}
catch {unset increasingDoubles}
catch {unset decreasingDoubles}
catch {unset increasingStrings}
catch {unset decreasingStrings}
catch {unset increasingDictionary}
catch {unset decreasingDictionary}
::tcltest::cleanupTests
return
|
Changes to tests/main.test.
1 2 | # This file contains a collection of tests for generic/tclMain.c. # | | | 1 2 3 4 5 6 7 8 9 10 |
# This file contains a collection of tests for generic/tclMain.c.
#
# RCS: @(#) $Id: main.test,v 1.13.2.4 2006/09/04 21:36:55 dgp Exp $
if {[catch {package require tcltest 2.0.2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required."
return
}
namespace eval ::tcl::test::main {
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 |
rename exit _exit
proc exit code {
puts "In exit"
_exit $code
}
} rc]
} -body {
| | | > > > > > > > > > > > > > > > > > > > > > | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
rename exit _exit
proc exit code {
puts "In exit"
_exit $code
}
} rc]
} -body {
exec [interpreter] << {} \
-appinitprocsetrcfile $rc >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
removeFile rc
} -result "application-specific initialization failed:\
\nExit MainLoop\nIn exit\neven 0\n"
test Tcl_Main-4.5 {
Tcl_Main: Bug 1481986
} -constraints {
exec Tcltest
} -setup {
set rc [makeFile {
testsetmainloop
after 0 {puts "Event callback"}
} rc]
} -body {
set f [open "|[list [interpreter] -appinitprocsetrcfile $rc]" w+]
after 1000
type $f {puts {Interactive output}
exit
}
read $f
} -cleanup {
catch {close $f}
removeFile rc
} -result "Event callback\nInteractive output\n"
# Tests Tcl_Main-5.*: interactive operations
test Tcl_Main-5.1 {
Tcl_Main: tcl_interactive must be boolean
} -constraints {
exec
|
| ︙ | ︙ | |||
835 836 837 838 839 840 841 842 843 844 845 846 847 848 |
close stdin} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\n% "
# Tests Tcl_Main-7.*: exiting
test Tcl_Main-7.1 {
Tcl_Main: [exit] defined as no-op -> still have exithandlers
} -constraints {
exec Tcltest
| > > > > > > > > > > > > > > > > > | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 |
close stdin} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\n% "
test Tcl_Main-6.7 {
[unknown]: interactive auto-completion.
} -constraints {
exec
} -body {
exec [interpreter] << {
proc foo\{ x {}
set ::auto_noexec xxx
set tcl_interactive 1
foo y} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\n% % "
# Tests Tcl_Main-7.*: exiting
test Tcl_Main-7.1 {
Tcl_Main: [exit] defined as no-op -> still have exithandlers
} -constraints {
exec Tcltest
|
| ︙ | ︙ |
Changes to tests/msgcat.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Note that after running these tests, entries will be left behind in the # message catalogs for locales foo, foo_BAR, and foo_BAR_baz. # | | | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Note that after running these tests, entries will be left behind in the
# message catalogs for locales foo, foo_BAR, and foo_BAR_baz.
#
# RCS: @(#) $Id: msgcat.test,v 1.11.2.4 2006/09/11 16:15:12 andreas_kupries Exp $
package require Tcl 8.2
if {[catch {package require tcltest 2}]} {
puts stderr "Skipping tests in [info script]. tcltest 2 required."
return
}
if {[catch {package require msgcat 1.3.4}]} {
puts stderr "Skipping tests in [info script]. No msgcat 1.3.4 found to test."
return
}
namespace eval ::msgcat::test {
namespace import ::msgcat::*
namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
|
| ︙ | ︙ | |||
50 51 52 53 54 55 56 |
variable count 0
variable body
variable result
variable setVars
foreach setVars [PowerSet $envVars] {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
| > > > | | > | | | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
variable count 0
variable body
variable result
variable setVars
foreach setVars [PowerSet $envVars] {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
set result [string tolower $::tcl::mac::locale]
} else {
set result c
}
}
test msgcat-0.$count [list \
locale initialization from environment variables $setVars \
] -setup {
variable var
foreach var $envVars {
catch {variable $var $::env($var)}
catch {unset ::env($var)}
}
foreach var $setVars {
set ::env($var) $var
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
mclocale en_US_funky
} -cleanup {
mclocale $locale
} -body {
mcpreferences
} -result {en_us_funky en_us en}
# Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
test msgcat-2.1 {mcset, global scope} {
namespace eval :: ::msgcat::mcset foo_BAR text1 text2
} {text2}
test msgcat-2.2 {mcset, global scope, default} {
namespace eval :: ::msgcat::mcset foo_BAR text3
} {text3}
| > > > > > > > > > > > > > > > > | | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
mclocale en_US_funky
} -cleanup {
mclocale $locale
} -body {
mcpreferences
} -result {en_us_funky en_us en}
test msgcat-1.12 {mclocale set, reject evil input} -setup {
variable locale [mclocale]
} -cleanup {
mclocale $locale
} -body {
mclocale /path/to/evil/code
} -returnCodes error -match glob -result {invalid newLocale value *}
test msgcat-1.13 {mclocale set, reject evil input} -setup {
variable locale [mclocale]
} -cleanup {
mclocale $locale
} -body {
mclocale looks/ok/../../../../but/is/path/to/evil/code
} -returnCodes error -match glob -result {invalid newLocale value *}
# Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
test msgcat-2.1 {mcset, global scope} {
namespace eval :: ::msgcat::mcset foo_BAR text1 text2
} {text2}
test msgcat-2.2 {mcset, global scope, default} {
namespace eval :: ::msgcat::mcset foo_BAR text3
} {text3}
test msgcat-2.2.1 {mcset, namespace overlap} {
namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz}
} {con1baz}
test msgcat-2.3 {mcset, namespace overlap} -setup {
namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
namespace eval baz {::msgcat::mcset foo_BAR con1 con1baz}
variable locale [mclocale]
|
| ︙ | ︙ |
Changes to tests/namespace.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Functionality covered: this file contains a collection of tests for the # procedures in tclNamesp.c that implement Tcl's basic support for # namespaces. Other namespace-related tests appear in variable.test. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Functionality covered: this file contains a collection of tests for the
# procedures in tclNamesp.c that implement Tcl's basic support for
# namespaces. Other namespace-related tests appear in variable.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: namespace.test,v 1.21.2.10 2006/10/04 17:59:06 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
|
| ︙ | ︙ | |||
129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
namespace eval test_ns_2 {
proc p {} {
return [namespace current]
}
}
list [test_ns_2::p] [namespace delete test_ns_2]
} {::test_ns_2 {}}
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_1 {
namespace export p
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 |
namespace eval test_ns_2 {
proc p {} {
return [namespace current]
}
}
list [test_ns_2::p] [namespace delete test_ns_2]
} {::test_ns_2 {}}
test namespace-7.3 {recursive Tcl_DeleteNamespace, active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
set x 1
trace add variable x unset "namespace delete [namespace current];#"
namespace delete [namespace current]
}
} {}
test namespace-7.4 {recursive Tcl_DeleteNamespace, active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
proc x {} {}
trace add command x delete "namespace delete [namespace current];#"
namespace delete [namespace current]
}
} {}
test namespace-7.5 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
set x 1
trace add variable x unset "namespace delete [namespace current];#"
}
namespace delete test_ns_2
} {}
test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
# [Bug 1355942]
namespace eval test_ns_2 {
proc x {} {}
trace add command x delete "namespace delete [namespace current];#"
}
namespace delete test_ns_2
} {}
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
interp create test_interp
interp eval test_interp {
namespace eval test_ns_1 {
namespace export p
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
namespace import ::test_ns_export::*
proc p {} {return foo}
}
list [lsort [info commands test_ns_import::*]] \
[namespace delete test_ns_export] \
[info commands test_ns_import::*]
} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p]
test namespace-9.1 {Tcl_Import, empty import pattern} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg
} {1 {empty import pattern}}
test namespace-9.2 {Tcl_Import, unknown namespace in import pattern} {
list [catch {namespace eval test_ns_import {namespace import fred::x}} msg] $msg
| > > > > > > > > > > > > > > > > > > > > > > > > > | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 |
namespace import ::test_ns_export::*
proc p {} {return foo}
}
list [lsort [info commands test_ns_import::*]] \
[namespace delete test_ns_export] \
[info commands test_ns_import::*]
} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1 ::test_ns_import::cmd2}] {} ::test_ns_import::p]
test namespace-8.5 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
interp create slave
slave eval {trace add execution error leave {namespace delete :: ;#}}
catch {slave eval error foo bar baz}
interp delete slave
set ::errorInfo
} {bar
invoked from within
"slave eval error foo bar baz"}
test namespace-8.6 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
interp create slave
slave eval {trace add variable errorCode write {namespace delete :: ;#}}
catch {slave eval error foo bar baz}
interp delete slave
set ::errorInfo
} {bar
invoked from within
"slave eval error foo bar baz"}
test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values} {
interp create slave
slave eval {trace add execution error leave {namespace delete :: ;#}}
catch {slave eval error foo bar baz}
interp delete slave
set ::errorCode
} baz
test namespace-9.1 {Tcl_Import, empty import pattern} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg
} {1 {empty import pattern}}
test namespace-9.2 {Tcl_Import, unknown namespace in import pattern} {
list [catch {namespace eval test_ns_import {namespace import fred::x}} msg] $msg
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 |
namespace import ::test_ns_export::*
proc p {} {return [cmd1 123]}
}
test_ns_import::p
} {cmd1: 123}
test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
| | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
namespace import ::test_ns_export::*
proc p {} {return [cmd1 123]}
}
test_ns_import::p
} {cmd1: 123}
test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} {0 {}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
namespace eval test_ns_import {
namespace import -force ::test_ns_export::*
cmd1 555
}
} {cmd1: 555}
test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} {
|
| ︙ | ︙ | |||
240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
[proc test_ns_export::cmd1 {args} {return "new1: $args"}] \
[namespace origin test_ns_import::cmd1] \
[namespace origin test_ns_export::cmd1] \
[test_ns_import::cmd1 g h i] \
[test_ns_export::cmd1 j k l]
} {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}}
test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace forget xyzzy::*} msg] $msg
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} {
namespace eval test_ns_export {
namespace export cmd1
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
[proc test_ns_export::cmd1 {args} {return "new1: $args"}] \
[namespace origin test_ns_import::cmd1] \
[namespace origin test_ns_export::cmd1] \
[test_ns_import::cmd1 g h i] \
[test_ns_export::cmd1 j k l]
} {{cmd1: a b c} {cmd1: d e f} {} ::test_ns_export::cmd1 ::test_ns_export::cmd1 {new1: g h i} {new1: j k l}}
test namespace-9.8 {Tcl_Import: Bug 1017299} -setup {
namespace eval one {
namespace export cmd
proc cmd {} {}
}
namespace eval two {
namespace export cmd
proc other args {}
}
namespace eval two \
[list namespace import [namespace current]::one::cmd]
namespace eval three \
[list namespace import [namespace current]::two::cmd]
namespace eval three {
rename cmd other
namespace export other
}
} -body {
namespace eval two [list namespace import -force \
[namespace current]::three::other]
namespace origin two::other
} -cleanup {
namespace delete one two three
} -match glob -result *::one::cmd
test namespace-9.9 {Tcl_Import: Bug 1017299} -setup {
namespace eval one {
namespace export cmd
proc cmd {} {}
}
namespace eval two namespace export cmd
namespace eval two \
[list namespace import [namespace current]::one::cmd]
namespace eval three namespace export cmd
namespace eval three \
[list namespace import [namespace current]::two::cmd]
} -body {
namespace eval two [list namespace import -force \
[namespace current]::three::cmd]
namespace origin two::cmd
} -cleanup {
namespace delete one two three
} -returnCodes error -match glob -result {import pattern * would create a loop*}
test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace forget xyzzy::*} msg] $msg
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} {
namespace eval test_ns_export {
namespace export cmd1
|
| ︙ | ︙ | |||
265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
set l {}
lappend l [lsort [info commands ::test_ns_import::*]]
namespace forget ::test_ns_export::cmd1
lappend l [info commands ::test_ns_import::*]
lappend l [catch {cmd1 777} msg] $msg
}
} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}]
test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 |
set l {}
lappend l [lsort [info commands ::test_ns_import::*]]
namespace forget ::test_ns_export::cmd1
lappend l [info commands ::test_ns_import::*]
lappend l [catch {cmd1 777} msg] $msg
}
} [list [lsort {::test_ns_import::p ::test_ns_import::cmd1}] ::test_ns_import::p 1 {invalid command name "cmd1"}]
test namespace-10.4 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval unrelated {
proc cmd {} {}
}
namespace eval my \
[list namespace import [namespace current]::origin::cmd]
} -body {
namespace eval my \
[list namespace forget [namespace current]::unrelated::cmd]
my::cmd
} -cleanup {
namespace delete origin unrelated my
}
test namespace-10.5 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval my \
[list namespace import [namespace current]::origin::cmd]
namespace eval my rename cmd newname
} -body {
namespace eval my \
[list namespace forget [namespace current]::origin::cmd]
my::newname
} -cleanup {
namespace delete origin my
} -returnCodes error -match glob -result *
test namespace-10.6 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval my \
[list namespace import [namespace current]::origin::cmd]
namespace eval your {}
namespace eval my \
[list rename cmd [namespace current]::your::newname]
} -body {
namespace eval your namespace forget newname
your::newname
} -cleanup {
namespace delete origin my your
} -returnCodes error -match glob -result *
test namespace-10.7 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval link namespace export cmd
namespace eval link \
[list namespace import [namespace current]::origin::cmd]
namespace eval link2 namespace export cmd
namespace eval link2 \
[list namespace import [namespace current]::link::cmd]
namespace eval my \
[list namespace import [namespace current]::link2::cmd]
} -body {
namespace eval my \
[list namespace forget [namespace current]::origin::cmd]
my::cmd
} -cleanup {
namespace delete origin link link2 my
} -returnCodes error -match glob -result *
test namespace-10.8 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval link namespace export cmd
namespace eval link \
[list namespace import [namespace current]::origin::cmd]
namespace eval link2 namespace export cmd
namespace eval link2 \
[list namespace import [namespace current]::link::cmd]
namespace eval my \
[list namespace import [namespace current]::link2::cmd]
} -body {
namespace eval my \
[list namespace forget [namespace current]::link::cmd]
my::cmd
} -cleanup {
namespace delete origin link link2 my
}
test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup {
namespace eval origin {
namespace export cmd
proc cmd {} {}
}
namespace eval link namespace export cmd
namespace eval link \
[list namespace import [namespace current]::origin::cmd]
namespace eval link2 namespace export cmd
namespace eval link2 \
[list namespace import [namespace current]::link::cmd]
namespace eval my \
[list namespace import [namespace current]::link2::cmd]
} -body {
namespace eval my \
[list namespace forget [namespace current]::link2::cmd]
my::cmd
} -cleanup {
namespace delete origin link link2 my
} -returnCodes error -match glob -result *
test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
}
|
| ︙ | ︙ | |||
774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $errorInfo
} {1 {invalid command name "xxxx"} {invalid command name "xxxx"
while executing
"xxxx"
(in namespace eval "::test_ns_1" script line 1)
invoked from within
"namespace eval test_ns_1 {xxxx}"}}
catch {unset v}
test namespace-26.1 {NamespaceExportCmd, no args and new ns} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace export
} {}
test namespace-26.2 {NamespaceExportCmd, just -clear arg} {
namespace export -clear
| > > > > > > > > > > > > > > > | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 |
list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $errorInfo
} {1 {invalid command name "xxxx"} {invalid command name "xxxx"
while executing
"xxxx"
(in namespace eval "::test_ns_1" script line 1)
invoked from within
"namespace eval test_ns_1 {xxxx}"}}
test namespace-25.7 {NamespaceEvalCmd, error in eval'd script} {
list [catch {namespace eval test_ns_1 {error foo bar baz}} msg] $msg $errorInfo
} {1 foo {bar
(in namespace eval "::test_ns_1" script line 1)
invoked from within
"namespace eval test_ns_1 {error foo bar baz}"}}
test namespace-25.8 {NamespaceEvalCmd, error in eval'd script} knownBug {
list [catch {namespace eval test_ns_1 error foo bar baz} msg] $msg $errorInfo
} {1 foo {bar
(in namespace eval "::test_ns_1" script line 1)
invoked from within
"namespace eval test_ns_1 error foo bar baz"}}
catch {unset v}
test namespace-25.9 {NamespaceEvalCmd, 545325} {
namespace eval test_ns_1 info level 0
} {namespace eval test_ns_1 info level 0}
test namespace-26.1 {NamespaceExportCmd, no args and new ns} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace export
} {}
test namespace-26.2 {NamespaceExportCmd, just -clear arg} {
namespace export -clear
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 896 897 898 899 900 901 902 |
}
namespace inscope test_ns_1 cmd
} {::test_ns_1::cmd: v=747, args=}
test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} {
list [namespace inscope test_ns_1 cmd x y z] \
[namespace eval test_ns_1 [concat cmd [list x y z]]]
} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}}
test namespace-30.1 {NamespaceOriginCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace origin} msg] $msg
} {1 {wrong # args: should be "namespace origin name"}}
test namespace-30.2 {NamespaceOriginCmd, bad args} {
list [catch {namespace origin x y} msg] $msg
| > > > > | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 |
}
namespace inscope test_ns_1 cmd
} {::test_ns_1::cmd: v=747, args=}
test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} {
list [namespace inscope test_ns_1 cmd x y z] \
[namespace eval test_ns_1 [concat cmd [list x y z]]]
} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}}
test namespace-29.6 {NamespaceInscopeCmd, 1400572} knownBug {
namespace inscope test_ns_1 {info level 0}
} {namespace inscope test_ns_1 {info level 0}}
test namespace-30.1 {NamespaceOriginCmd, bad args} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {namespace origin} msg] $msg
} {1 {wrong # args: should be "namespace origin name"}}
test namespace-30.2 {NamespaceOriginCmd, bad args} {
list [catch {namespace origin x y} msg] $msg
|
| ︙ | ︙ |
Changes to tests/notify.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # generates output for errors. No output means no errors were found. # # Copyright (c) 2003 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 2003 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: notify.test,v 1.2.2.1 2003/10/06 13:55:38 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
testConstraint testevent [llength [info commands testevent]]
test notify-1.1 {Tcl_QueueEvent and delivery of a single event} \
-constraints {testevent} \
|
| ︙ | ︙ |
Changes to tests/obj.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Functionality covered: this file contains a collection of tests for the # procedures in tclObj.c that implement Tcl's basic type support and the # type managers for the types boolean, double, and integer. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
# Functionality covered: this file contains a collection of tests for the
# procedures in tclObj.c that implement Tcl's basic type support and the
# type managers for the types boolean, double, and integer.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: obj.test,v 1.7.2.1 2004/09/10 21:52:37 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[info commands testobj] == {}} {
puts "This application hasn't been compiled with the \"testobj\""
puts "command, so I can't test the Tcl type and object support."
::tcltest::cleanupTests
return
}
# Procedure to determine the integer range of the machine
proc int_range {} {
for { set MIN_INT 1 } { $MIN_INT > 0 } {} {
set MIN_INT [expr { $MIN_INT << 1 }]
}
set MAX_INT [expr { ~ $MIN_INT }]
return [list $MIN_INT $MAX_INT]
}
# Procedure to determine the range of wide integers on the machine.
proc wide_range {} {
for { set MIN_WIDE [expr { wide(1) }] } { $MIN_WIDE > wide(0) } {} {
set MIN_WIDE [expr { $MIN_WIDE << 1 }]
}
set MAX_WIDE [expr { ~ $MIN_WIDE }]
return [list $MIN_WIDE $MAX_WIDE]
}
foreach { MIN_INT MAX_INT } [int_range] break
foreach { MIN_WIDE MAX_WIDE } [wide_range] break
::tcltest::testConstraint 32bit \
[expr { $MAX_INT == 0x7fffffff }]
::tcltest::testConstraint wideBiggerThanInt \
[expr { $MAX_WIDE > wide($MAX_INT) }]
test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} {
set r 1
foreach {t} {
{array search}
boolean
bytearray
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 599 600 601 602 603 604 |
test obj-31.6 {regenerate string rep of "end--bigInteger"} {nonPortable} {
testobj freeallvars
teststringobj set 1 end--0x80000000
testobj convert 1 end-offset
testobj invalidateStringRep 1
} end--2147483648
testobj freeallvars
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 |
test obj-31.6 {regenerate string rep of "end--bigInteger"} {nonPortable} {
testobj freeallvars
teststringobj set 1 end--0x80000000
testobj convert 1 end-offset
testobj invalidateStringRep 1
} end--2147483648
test obj-32.1 {integer overflow on input} {32bit wideBiggerThanInt} {
set x 0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 2147483648}
test obj-32.2 {integer overflow on input} {32bit wideBiggerThanInt} {
set x 0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 4294967295}
test obj-32.3 {integer overflow on input} {32bit wideBiggerThanInt} {
set x 0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {0 4294967296}
test obj-32.4 {integer overflow on input} {32bit wideBiggerThanInt} {
set x -0x8000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483648}
test obj-32.5 {integer overflow on input} {32bit wideBiggerThanInt} {
set x -0x8000; append x 0001
list [string is integer $x] [expr { wide($x) }]
} {1 -2147483649}
test obj-32.6 {integer overflow on input} {32bit wideBiggerThanInt} {
set x -0xffff; append x ffff
list [string is integer $x] [expr { wide($x) }]
} {1 -4294967295}
test obj-32.7 {integer overflow on input} {32bit wideBiggerThanInt} {
set x -0x10000; append x 0000
list [string is integer $x] [expr { wide($x) }]
} {0 -4294967296}
testobj freeallvars
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/parse.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclParse.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file contains a collection of tests for the procedures in the
# file tclParse.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parse.test,v 1.11.2.5 2006/03/07 05:30:24 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[info commands testparser] == {}} {
puts "This application hasn't been compiled with the \"testparser\""
puts "command, so I can't test the Tcl parser."
::tcltest::cleanupTests
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 |
list [catch {testparser {[a]} 2} msg] $msg
} {1 {missing close-bracket}}
test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} {
testparser {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 0
} {- {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 16 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 {}}
| > > | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 |
list [catch {testparser {[a]} 2} msg] $msg
} {1 {missing close-bracket}}
test parse-7.1 {Tcl_FreeParse and ExpandTokenArray procedures} {
testparser {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 0
} {- {$a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) $a(b) } 16 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 word {$a(b)} 3 variable {$a(b)} 2 text a 0 text b 0 {}}
testConstraint testevalobjv [llength [info commands testevalobjv]]
testConstraint testevalex [llength [info commands testevalex]]
test parse-8.1 {Tcl_EvalObjv procedure} testevalobjv {
testevalobjv 0 concat this is a test
} {this is a test}
test parse-8.2 {Tcl_EvalObjv procedure, unknown commands} testevalobjv {
rename unknown unknown.old
set x [catch {testevalobjv 10 asdf poiu} msg]
rename unknown.old unknown
list $x $msg
} {1 {invalid command name "asdf"}}
test parse-8.3 {Tcl_EvalObjv procedure, unknown commands} testevalobjv {
rename unknown unknown.old
proc unknown args {
return "unknown $args"
}
set x [catch {testevalobjv 0 asdf poiu} msg]
rename unknown {}
rename unknown.old unknown
list $x $msg
} {0 {unknown asdf poiu}}
test parse-8.4 {Tcl_EvalObjv procedure, unknown commands} testevalobjv {
rename unknown unknown.old
proc unknown args {
error "I don't like that command"
}
set x [catch {testevalobjv 0 asdf poiu} msg]
rename unknown {}
rename unknown.old unknown
list $x $msg
} {1 {I don't like that command}}
test parse-8.5 {Tcl_EvalObjv procedure, command traces} testevalobjv {
testevalobjv 0 set x 123
testcmdtrace tracetest {testevalobjv 0 set x $x}
} {{testevalobjv 0 set x $x} {testevalobjv 0 set x 123} {set x 123} {set x 123}}
test parse-8.7 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL flag} testevalobjv {
proc x {} {
set y 23
set z [testevalobjv 1 set y]
return [list $z $y]
}
catch {unset y}
set y 16
x
} {16 23}
test parse-8.8 {Tcl_EvalObjv procedure, async handlers} testevalobjv {
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
return "new result"
}
set handler1 [testasync create async1]
set aresult xxx
set acode yyy
set x [list [catch [list testevalobjv 0 testasync mark $handler1 original 0] msg] $msg $acode $aresult]
testasync delete
set x
} {0 {new result} 0 original}
test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv {
list [catch {testevalobjv 0 error message} msg] $msg
} {1 message}
test parse-8.10 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL} testevalobjv {
rename ::unknown unknown.save
proc ::unknown args {lappend ::info [info level]}
catch {rename ::noSuchCommand {}}
set ::info {}
namespace eval test_ns_1 {
testevalobjv 1 noSuchCommand
uplevel #0 noSuchCommand
}
namespace delete test_ns_1
rename ::unknown {}
rename unknown.save ::unknown
set ::info
} {1 1}
test parse-8.11 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} testevalobjv {
rename ::unknown unknown.save
proc ::unknown args {lappend ::info [info level]; uplevel 1 foo}
proc ::foo args {lappend ::info global}
catch {rename ::noSuchCommand {}}
set ::slave [interp create]
$::slave alias bar noSuchCommand
set ::info {}
namespace eval test_ns_1 {
proc foo args {lappend ::info namespace}
$::slave eval bar
testevalobjv 1 [list $::slave eval bar]
uplevel #0 [list $::slave eval bar]
}
namespace delete test_ns_1
rename ::foo {}
rename ::unknown {}
rename unknown.save ::unknown
set ::info
} [subst {[set level 2; incr level [info level]] global 1 global 1 global}]
test parse-8.12 {Tcl_EvalObjv procedure, TCL_EVAL_INVOKE} {
set ::auto_index(noSuchCommand) {
proc noSuchCommand {} {lappend ::info global}
}
set ::auto_index(::[string trimleft [namespace current]::test_ns_1::noSuchCommand :]) [list \
proc [namespace current]::test_ns_1::noSuchCommand {} {
lappend ::info ns
}]
catch {rename ::noSuchCommand {}}
set ::slave [interp create]
$::slave alias bar noSuchCommand
set ::info {}
namespace eval test_ns_1 {
$::slave eval bar
}
namespace delete test_ns_1
interp delete $::slave
catch {rename ::noSuchCommand {}}
set ::info
} global
test parse-9.1 {Tcl_LogCommandInfo, line numbers} {
catch {unset x}
list [catch {testevalex {for {} 1 {} {
# asdf
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 |
} 0
test parse-15.57 {CommandComplete procedure} {
info complete "# Comment should be complete command"
} 1
test parse-15.58 {CommandComplete procedure, memory leaks} {
info complete "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22"
} 1
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 |
} 0
test parse-15.57 {CommandComplete procedure} {
info complete "# Comment should be complete command"
} 1
test parse-15.58 {CommandComplete procedure, memory leaks} {
info complete "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22"
} 1
test parse-15.59 {CommandComplete procedure} {
# Test for Tcl Bug 684744
info complete [encoding convertfrom identity "\x00;if 1 \{"]
} 0
test parse-16.1 {Tcl_EvalEx, check termOffset is set correctly for non TCL_OK cases, bug 2535} {
subst {[eval {return foo}]bar}
} foobar
test parse-17.1 {Correct return codes from errors during substitution} {
catch {eval {w[continue]}}
} 4
test parse-19.1 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints {
testevalex
} -setup {
interp create i
load {} Tcltest i
i eval {proc {} args {}}
interp recursionlimit i 3
} -body {
i eval {testevalex {[]}}
} -cleanup {
interp delete i
}
test parse-19.2 {Bug 1115904: recursion limit in Tcl_EvalEx} -constraints {
testevalex
} -setup {
interp create i
load {} Tcltest i
i eval {proc {} args {}}
interp recursionlimit i 3
} -body {
i eval {testevalex {[[]]}}
} -cleanup {
interp delete i
} -returnCodes error -match glob -result {too many nested*}
test parse-19.3 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
interp create i
i eval {proc {} args {}}
interp recursionlimit i 3
} -body {
i eval {subst {[]}}
} -cleanup {
interp delete i
}
test parse-19.4 {Bug 1115904: recursion limit in Tcl_EvalEx} -setup {
interp create i
i eval {proc {} args {}}
interp recursionlimit i 3
} -body {
i eval {subst {[[]]}}
} -cleanup {
interp delete i
} -returnCodes error -match glob -result {too many nested*}
# cleanup
catch {unset a}
::tcltest::cleanupTests
return
|
Changes to tests/parseExpr.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for the procedures in the # file tclParseExpr.c. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# This file contains a collection of tests for the procedures in the
# file tclParseExpr.c. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseExpr.test,v 1.10.2.1 2003/10/06 13:55:39 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Note that the Tcl expression parser (tclParseExpr.c) does not check
# the semantic validity of the expressions it parses. It does not check,
# for example, that a math function actually exists, or that the operands
# of "<<" are integers.
|
| ︙ | ︙ |
Changes to tests/parseOld.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: parseOld.test,v 1.11.2.1 2003/03/27 13:49:22 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
tcltest::testConstraint testwordend \
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 324 325 326 327 328 329 330 |
set msg
} {missing close-brace}
test parseOld-10.3 {syntax errors} {catch {set a "bcd} msg} 1
test parseOld-10.4 {syntax errors} {
catch {set a "bcd} msg
set msg
} {missing "}
test parseOld-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1
test parseOld-10.6 {syntax errors} {
catch {set a "bcd"xy} msg
set msg
} {extra characters after close-quote}
test parseOld-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1
test parseOld-10.8 {syntax errors} {
| > | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 |
set msg
} {missing close-brace}
test parseOld-10.3 {syntax errors} {catch {set a "bcd} msg} 1
test parseOld-10.4 {syntax errors} {
catch {set a "bcd} msg
set msg
} {missing "}
#" Emacs formatting >:^(
test parseOld-10.5 {syntax errors} {catch {set a "bcd"xy} msg} 1
test parseOld-10.6 {syntax errors} {
catch {set a "bcd"xy} msg
set msg
} {extra characters after close-quote}
test parseOld-10.7 {syntax errors} {catch "set a {bcd}xy" msg} 1
test parseOld-10.8 {syntax errors} {
|
| ︙ | ︙ | |||
415 416 417 418 419 420 421 |
set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ]
llength $a
} 62
set i 0
foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] {
set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i]
set test $test$test$test$test
| < | | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 |
set a [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ]
llength $a
} 62
set i 0
foreach j [concat 0000 1111 2222 3333 4444 5555 6666 7777 8888 9999 aaaa bbbb cccc dddd eeee ffff gggg hhhh iiii jjjj kkkk llll mmmm nnnn oooo pppp qqqq rrrr ssss tttt uuuu vvvv wwww xxxx yyyy zzzz AAAA BBBB CCCC DDDD EEEE FFFF GGGG HHHH IIII JJJJ KKKK LLLL MMMM NNNN OOOO PPPP QQQQ RRRR SSSS TTTT UUUU VVVV WWWW XXXX YYYY ZZZZ] {
set test [string index 0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ $i]
set test $test$test$test$test
test parseOld-11.10-[incr i] {long values} {
set j
} $test
}
test parseOld-11.11 {test buffer overflow in backslashes in braces} {
expr {"a" == {xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101\101}}
} 0
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
} {}
test parseOld-14.3 {TclWordEnd procedure} {testwordend} {
testwordend " \\\n "
} { }
test parseOld-14.4 {TclWordEnd procedure} {testwordend} {
testwordend {"abc"}
} {"}
test parseOld-14.5 {TclWordEnd procedure} {testwordend} {
testwordend {{xyz}}
} \}
test parseOld-14.6 {TclWordEnd procedure} {testwordend} {
testwordend {{a{}b{}\}} xyz}
} "\} xyz"
test parseOld-14.7 {TclWordEnd procedure} {testwordend} {
| > | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 |
} {}
test parseOld-14.3 {TclWordEnd procedure} {testwordend} {
testwordend " \\\n "
} { }
test parseOld-14.4 {TclWordEnd procedure} {testwordend} {
testwordend {"abc"}
} {"}
#" Emacs formatting >:^(
test parseOld-14.5 {TclWordEnd procedure} {testwordend} {
testwordend {{xyz}}
} \}
test parseOld-14.6 {TclWordEnd procedure} {testwordend} {
testwordend {{a{}b{}\}} xyz}
} "\} xyz"
test parseOld-14.7 {TclWordEnd procedure} {testwordend} {
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
} {c}
test parseOld-14.18 {TclWordEnd procedure} {testwordend} {
testwordend \[a\000\]
} {]}
test parseOld-14.19 {TclWordEnd procedure} {testwordend} {
testwordend \"a\000\"
} {"}
test parseOld-14.20 {TclWordEnd procedure} {testwordend} {
testwordend a{\000}b
} {b}
test parseOld-14.21 {TclWordEnd procedure} {testwordend} {
testwordend " \000b"
} {b}
| > | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 |
} {c}
test parseOld-14.18 {TclWordEnd procedure} {testwordend} {
testwordend \[a\000\]
} {]}
test parseOld-14.19 {TclWordEnd procedure} {testwordend} {
testwordend \"a\000\"
} {"}
#" Emacs formatting >:^(
test parseOld-14.20 {TclWordEnd procedure} {testwordend} {
testwordend a{\000}b
} {b}
test parseOld-14.21 {TclWordEnd procedure} {testwordend} {
testwordend " \000b"
} {b}
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
info complete "xyz \[abc"
} {0}
# cleanup
set argv $savedArgv
::tcltest::cleanupTests
return
| < < < < < < < < < < < < | 540 541 542 543 544 545 546 |
info complete "xyz \[abc"
} {0}
# cleanup
set argv $savedArgv
::tcltest::cleanupTests
return
|
Changes to tests/pid.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: pid # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1995 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | < < < | > | > > < > > | | > > > | > > < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
# Commands covered: pid
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1995 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: pid.test,v 1.8.2.2 2004/02/25 23:38:17 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# If pid is not defined just return with no error
# Some platforms may not have the pid command implemented
if {[info commands pid] == ""} {
puts "pid is not implemented for this machine"
::tcltest::cleanupTests
return
}
test pid-1.1 {pid command} {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} -constraints {unixOrPc unixExecs} -setup {
set path(test1) [makeFile {} test1]
file delete $path(test1)
} -body {
set f [open |[list echo foo | cat >$path(test1)] w]
set pids [pid $f]
close $f
list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
[regexp {^[0-9]+$} [lindex $pids 1]] \
[expr {[lindex $pids 0] == [lindex $pids 1]}]
} -cleanup {
removeFile test1
} -result {2 1 1 0}
test pid-1.3 {pid command} -setup {
set path(test1) [makeFile {} test1]
file delete $path(test1)
} -body {
set f [open $path(test1) w]
set pids [pid $f]
close $f
set pids
} -cleanup {
removeFile test1
} -result {}
test pid-1.4 {pid command} {
list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}
test pid-1.5 {pid command} {
list [catch {pid gorp} msg] $msg
} {1 {can not find channel named "gorp"}}
# cleanup
::tcltest::cleanupTests
return
|
| ︙ | ︙ |
Changes to tests/pkg.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: pkg # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
# Commands covered: pkg
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: pkg.test,v 1.9.12.10 2007/02/22 20:25:29 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Do all this in a slave interp to avoid garbaging the
# package list
set i [interp create]
interp eval $i [list set argv $argv]
interp eval $i [list package require tcltest 2]
interp eval $i [list namespace import -force ::tcltest::*]
interp eval $i {
eval package forget [package names]
set oldPkgUnknown [package unknown]
package unknown {}
set oldPath $auto_path
set auto_path ""
testConstraint tip268 [info exists tcl_platform(tip,268)]
testConstraint !tip268 [expr {![info exists tcl_platform(tip,268)]}]
test pkg-1.1 {Tcl_PkgProvide procedure} {
package forget t
package provide t 2.3
} {}
test pkg-1.2 {Tcl_PkgProvide procedure} {
package forget t
package provide t 2.3
|
| ︙ | ︙ | |||
51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
list [catch {package provide t 3.3} msg] $msg
} {1 {conflicting versions provided for package "t": 2.3, then 3.3}}
test pkg-1.5 {Tcl_PkgProvide procedure} {
package forget t
package provide t 2.3
package provide t 2.3
} {}
test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} {
package forget t
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
set x xxx
| > > > > > > > > > > > > > > > > > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
list [catch {package provide t 3.3} msg] $msg
} {1 {conflicting versions provided for package "t": 2.3, then 3.3}}
test pkg-1.5 {Tcl_PkgProvide procedure} {
package forget t
package provide t 2.3
package provide t 2.3
} {}
test pkg-1.6 {Tcl_PkgProvide procedure} tip268 {
package forget t
package provide t 2.3a1
} {}
set n 0
foreach v {
2.3k1 2a3a2 2ab3 2.a4 2.b4 2b.4 2a.4 2ba4 2a4b1
2b4a1 2b3b2
} {
test pkg-1.7.$n {Tcl_PkgProvide procedure} tip268 {
package forget t
list [catch {package provide t $v} msg] $msg
} [list 1 "expected version number but got \"$v\""]
incr n
}
test pkg-2.1 {Tcl_PkgRequire procedure, picking best version} {
package forget t
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
set x xxx
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
package forget t
package unknown {}
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
list [catch {package require t 4.1} msg] $msg
} {1 {can't find package t 4.1}}
| | > > > > > > > > > > | | | | | | | > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 |
package forget t
package unknown {}
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
list [catch {package require t 4.1} msg] $msg
} {1 {can't find package t 4.1}}
test pkg-2.8 {Tcl_PkgRequire procedure, can't find suitable version} !tip268 {
package forget t
package unknown {}
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
list [catch {package require -exact t 1.3} msg] $msg
} {1 {can't find package t 1.3}}
test pkg-2.8-268 {Tcl_PkgRequire procedure, can't find suitable version} tip268 {
package forget t
package unknown {}
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
list [catch {package require -exact t 1.3} msg] $msg
} {1 {can't find package t 1.3-1.4}}
test pkg-2.9 {Tcl_PkgRequire procedure, can't find suitable version} {
package forget t
package unknown {}
list [catch {package require t} msg] $msg
} {1 {can't find package t}}
test pkg-2.10 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
package forget t
package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test"}
list [catch {package require t 2.1} msg] $msg $errorInfo
} -match glob -result {1 {ifneeded test} {ifneeded test
while executing
"error "ifneeded test""
("package ifneeded*" script)
invoked from within
"package require t 2.1"}}
test pkg-2.11 {Tcl_PkgRequire procedure, ifneeded script doesn't provide package} -body {
package forget t
package ifneeded t 2.1 "set x invoked"
set x xxx
list [catch {package require t 2.1} msg] $msg $x
} -match glob -result {1 * invoked}
test pkg-2.12 {Tcl_PkgRequire procedure, self-deleting script} {
package forget t
package ifneeded t 1.2 "package forget t; set x 1.2; package provide t 1.2"
set x xxx
package require t 1.2
set x
} {1.2}
test pkg-2.13-!268 {Tcl_PkgRequire procedure, "package unknown" support} !tip268 {
proc pkgUnknown args {
global x
set x $args
package provide [lindex $args 0] [lindex $args 1]
}
package forget t
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
package unknown pkgUnknown
set x xxx
package require -exact t 1.5
package unknown {}
set x
} {t 1.5 -exact}
test pkg-2.13-268 {Tcl_PkgRequire procedure, "package unknown" support} tip268 {
proc pkgUnknown args {
# args = name requirement
# requirement = v-v (for exact version)
global x
set x $args
package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0]
}
package forget t
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
package unknown pkgUnknown
set x xxx
package require -exact t 1.5
package unknown {}
set x
} {t 1.5-1.6}
test pkg-2.14 {Tcl_PkgRequire procedure, "package unknown" support} {
proc pkgUnknown args {
package ifneeded t 1.2 "set x loaded; package provide t 1.2"
}
package forget t
package unknown pkgUnknown
set x xxx
set result [list [package require t] $x]
package unknown {}
set result
} {1.2 loaded}
test pkg-2.15 {Tcl_PkgRequire procedure, "package unknown" support} !tip268 {
proc pkgUnknown args {
global x
set x $args
package provide [lindex $args 0] 2.0
}
package forget {a b}
package unknown pkgUnknown
set x xxx
package require {a b}
package unknown {}
set x
} {{a b} {}}
test pkg-2.15-268 {Tcl_PkgRequire procedure, "package unknown" support} tip268 {
proc pkgUnknown args {
global x
set x $args
package provide [lindex $args 0] 2.0
}
package forget {a b}
package unknown pkgUnknown
set x xxx
package require {a b}
package unknown {}
set x
} {{a b} 0-}
test pkg-2.16 {Tcl_PkgRequire procedure, "package unknown" error} !tip268 {
proc pkgUnknown args {
error "testing package unknown"
}
package forget t
package unknown pkgUnknown
set result [list [catch {package require t} msg] $msg $errorInfo]
package unknown {}
set result
} {1 {testing package unknown} {testing package unknown
while executing
"error "testing package unknown""
(procedure "pkgUnknown" line 2)
invoked from within
"pkgUnknown t {}"
("package unknown" script)
invoked from within
"package require t"}}
test pkg-2.16-268 {Tcl_PkgRequire procedure, "package unknown" error} tip268 {
proc pkgUnknown args {
error "testing package unknown"
}
package forget t
package unknown pkgUnknown
set result [list [catch {package require t} msg] $msg $errorInfo]
package unknown {}
set result
} {1 {testing package unknown} {testing package unknown
while executing
"error "testing package unknown""
(procedure "pkgUnknown" line 2)
invoked from within
"pkgUnknown t 0-"
("package unknown" script)
invoked from within
"package require t"}}
test pkg-2.17 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} !tip268 {
proc pkgUnknown args {
global x
set x $args
}
package forget t
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
package unknown pkgUnknown
set x xxx
set result [list [catch {package require -exact t 1.5} msg] $msg $x]
package unknown {}
set result
} {1 {can't find package t 1.5} {t 1.5 -exact}}
test pkg-2.17-268 {Tcl_PkgRequire procedure, "package unknown" doesn't load package} tip268 {
proc pkgUnknown args {
global x
set x $args
}
package forget t
foreach i {1.4 3.4 2.3 2.4 2.2} {
package ifneeded t $i "set x $i"
}
package unknown pkgUnknown
set x xxx
set result [list [catch {package require -exact t 1.5} msg] $msg $x]
package unknown {}
set result
} {1 {can't find package t 1.5-1.6} {t 1.5-1.6}}
test pkg-2.18 {Tcl_PkgRequire procedure, version checks} {
package forget t
package provide t 2.3
package require t
} {2.3}
test pkg-2.19 {Tcl_PkgRequire procedure, version checks} {
package forget t
|
| ︙ | ︙ | |||
252 253 254 255 256 257 258 |
list [catch {package require t 1.2} msg] $msg
} {1 {version conflict for package "t": have 2.3, need 1.2}}
test pkg-2.23 {Tcl_PkgRequire procedure, version checks} {
package forget t
package provide t 2.3
package require -exact t 2.3
} {2.3}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
list [catch {package require t 1.2} msg] $msg
} {1 {version conflict for package "t": have 2.3, need 1.2}}
test pkg-2.23 {Tcl_PkgRequire procedure, version checks} {
package forget t
package provide t 2.3
package require -exact t 2.3
} {2.3}
test pkg-2.24 {Tcl_PkgRequire procedure, version checks} !tip268 {
package forget t
package provide t 2.3
list [catch {package require -exact t 2.2} msg] $msg
} {1 {version conflict for package "t": have 2.3, need 2.2}}
test pkg-2.24-268 {Tcl_PkgRequire procedure, version checks} tip268 {
package forget t
package provide t 2.3
list [catch {package require -exact t 2.2} msg] $msg
} {1 {version conflict for package "t": have 2.3, need 2.2-2.3}}
test pkg-2.25 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
package forget t
package ifneeded t 2.1 {package provide t 2.1; error "ifneeded test" EI}
list [catch {package require t 2.1} msg] $msg $errorInfo
} -match glob -result {1 {ifneeded test} {EI
("package ifneeded*" script)
invoked from within
"package require t 2.1"}} -constraints knownBug
test pkg-2.26 {Tcl_PkgRequire procedure, error in ifneeded script} -body {
package forget t
package ifneeded t 2.1 {package provide t 2.1; foreach x 1 {error "ifneeded test" EI}}
list [catch {package require t 2.1} msg] $msg $errorInfo
} -match glob -result {1 {ifneeded test} {EI
("foreach" body line 1)
invoked from within
"foreach x 1 {error "ifneeded test" EI}"
("package ifneeded*" script)
invoked from within
"package require t 2.1"}}
test pkg-2.27 {Tcl_PkgRequire: circular dependency} -setup {
package forget foo
} -body {
package ifneeded foo 1 {package require foo 1}
package require foo 1
} -cleanup {
package forget foo
} -returnCodes error -match glob -result {circular package dependency:*}
test pkg-2.28 {Tcl_PkgRequire: circular dependency} -setup {
package forget foo
} -body {
package ifneeded foo 1 {package require foo 2}
package require foo 1
} -cleanup {
package forget foo
} -returnCodes error -match glob -result {circular package dependency:*}
test pkg-2.29 {Tcl_PkgRequire: circular dependency} -setup {
package forget foo
package forget bar
} -body {
package ifneeded foo 1 {package require bar 1; package provide foo 1}
package ifneeded bar 1 {package require foo 1; package provide bar 1}
package require foo 1
} -cleanup {
package forget foo
package forget bar
} -returnCodes error -match glob -result {circular package dependency:*}
test pkg-2.30 {Tcl_PkgRequire: circular dependency} -setup {
package forget foo
package forget bar
} -body {
package ifneeded foo 1 {package require bar 1; package provide foo 1}
package ifneeded foo 2 {package provide foo 2}
package ifneeded bar 1 {package require foo 2; package provide bar 1}
package require foo 1
} -cleanup {
package forget foo
package forget bar
} -returnCodes error -match glob -result {circular package dependency:*}
test pkg-2.31 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1 {package provide foo 1; error foo}
package require foo 1
} -cleanup {
package forget foo
} -returnCodes error -match glob -result foo
test pkg-2.32 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1 {package provide foo 1; error foo}
catch {package require foo 1}
package provide foo
} -cleanup {
package forget foo
} -result {}
test pkg-2.33 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1 {package provide foo 2}
package require foo 1
} -cleanup {
package forget foo
} -returnCodes error -match glob -result {attempt to provide package * failed:*}
test pkg-2.34 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1 {package provide foo 1.1}
package require foo 1
} -cleanup {
package forget foo
} -result 1.1
test pkg-2.34.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1.1 {package provide foo 1}
package require foo 1
} -cleanup {
package forget foo
} -result 1
test pkg-2.34.2 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1.1 {package provide foo 1}
package require foo 1.1
} -cleanup {
package forget foo
} -returnCodes error -match glob -result {attempt to provide package * failed:*}
test pkg-2.35 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1 {}
package require foo 1
} -cleanup {
package forget foo
} -returnCodes error -match glob -result {attempt to provide package * failed:*}
test pkg-2.35.1 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1 {break}
package require foo 1
} -cleanup {
package forget foo
} -returnCodes error -match glob \
-result {attempt to provide package * failed: bad return code:*}
test pkg-2.36 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1 {continue}
package require foo 1
} -cleanup {
package forget foo
} -returnCodes error -match glob \
-result {attempt to provide package * failed: bad return code:*}
test pkg-2.37 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1 {return}
package require foo 1
} -cleanup {
package forget foo
} -returnCodes error -match glob \
-result {attempt to provide package * failed: bad return code:*}
test pkg-2.38 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
} -body {
package ifneeded foo 1 {proc x {} {return -code 10}; x}
package require foo 1
} -cleanup {
rename x {}
package forget foo
} -returnCodes error -match glob \
-result {attempt to provide package * failed: bad return code:*}
test pkg-2.39 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
set saveUnknown [package unknown]
package unknown {package provide foo 2 ;#}
} -body {
package require foo 1
} -cleanup {
package forget foo
package unknown $saveUnknown
} -returnCodes error -match glob -result *
test pkg-2.40 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
set saveUnknown [package unknown]
package unknown {break ;#}
} -body {
package require foo 1
} -cleanup {
package forget foo
package unknown $saveUnknown
} -returnCodes error -match glob -result {bad return code:*}
test pkg-2.41 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
set saveUnknown [package unknown]
package unknown {continue ;#}
} -body {
package require foo 1
} -cleanup {
package forget foo
package unknown $saveUnknown
} -returnCodes error -match glob -result {bad return code:*}
test pkg-2.42 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
set saveUnknown [package unknown]
package unknown {return ;#}
} -body {
package require foo 1
} -cleanup {
package forget foo
package unknown $saveUnknown
} -returnCodes error -match glob -result {bad return code:*}
test pkg-2.43 {Tcl_PkgRequire: consistent return values (1162286)} -setup {
package forget foo
set saveUnknown [package unknown]
proc x args {return -code 10}
package unknown x
} -body {
package require foo 1
} -cleanup {
rename x {}
package forget foo
package unknown $saveUnknown
} -returnCodes error -match glob -result {bad return code:*}
test pkg-2.50 {Tcl_PkgRequire procedure, picking best stable version} tip268 {
package forget t
foreach i {1.4 3.4 4.0a1 2.3 2.4 2.2} {
package ifneeded t $i "set x $i; package provide t $i"
}
set x xxx
package require t
set x
} {3.4}
test pkg-2.51 {Tcl_PkgRequire procedure, picking best stable version} tip268 {
package forget t
foreach i {1.2b1 1.2 1.3a2 1.3} {
package ifneeded t $i "set x $i; package provide t $i"
}
set x xxx
package require t
set x
} {1.3}
test pkg-2.52 {Tcl_PkgRequire procedure, picking best stable version} tip268 {
package forget t
foreach i {1.2b1 1.2 1.3 1.3a2} {
package ifneeded t $i "set x $i; package provide t $i"
}
set x xxx
package require t
set x
} {1.3}
test pkg-3.1 {Tcl_PackageCmd procedure} {
list [catch {package} msg] $msg
} {1 {wrong # args: should be "package option ?arg arg ...?"}}
test pkg-3.2 {Tcl_PackageCmd procedure, "forget" option} {
foreach i [package names] {
package forget $i
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 |
package provide t 2.3
package provide t
} {2.3}
test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} {
package forget t
list [catch {package provide t a.b} msg] $msg
} {1 {expected version number but got "a.b"}}
| | > > > | | > > > > > | | > > > | > > > | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
package provide t 2.3
package provide t
} {2.3}
test pkg-3.21 {Tcl_PackageCmd procedure, "provide" option} {
package forget t
list [catch {package provide t a.b} msg] $msg
} {1 {expected version number but got "a.b"}}
test pkg-3.22 {Tcl_PackageCmd procedure, "require" option} !tip268 {
list [catch {package require} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
test pkg-3.22-268 {Tcl_PackageCmd procedure, "require" option} tip268 {
list [catch {package require} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
test pkg-3.23 {Tcl_PackageCmd procedure, "require" option} !tip268 {
list [catch {package require a b c} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
test pkg-3.24 {Tcl_PackageCmd procedure, "require" option} !tip268 {
list [catch {package require -exact a b c} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
test pkg-3.24-268 {Tcl_PackageCmd procedure, "require" option} tip268 {
list [catch {package require -exact a b c} msg] $msg
# Exact syntax: -exact name version
# name ?requirement...?
} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
test pkg-3.25 {Tcl_PackageCmd procedure, "require" option} !tip268 {
list [catch {package require -bs a b} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
test pkg-3.26 {Tcl_PackageCmd procedure, "require" option} {
list [catch {package require x a.b} msg] $msg
} {1 {expected version number but got "a.b"}}
test pkg-3.27 {Tcl_PackageCmd procedure, "require" option} {
list [catch {package require -exact x a.b} msg] $msg
} {1 {expected version number but got "a.b"}}
test pkg-3.28 {Tcl_PackageCmd procedure, "require" option} !tip268 {
list [catch {package require -exact x} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
test pkg-3.28-268 {Tcl_PackageCmd procedure, "require" option} tip268 {
list [catch {package require -exact x} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
test pkg-3.29 {Tcl_PackageCmd procedure, "require" option} !tip268 {
list [catch {package require -exact} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?version?"}}
test pkg-3.29-268 {Tcl_PackageCmd procedure, "require" option} tip268 {
list [catch {package require -exact} msg] $msg
} {1 {wrong # args: should be "package require ?-exact? package ?requirement...?"}}
test pkg-3.30 {Tcl_PackageCmd procedure, "require" option} {
package forget t
package provide t 2.3
package require t 2.1
} {2.3}
test pkg-3.31 {Tcl_PackageCmd procedure, "require" option} {
package forget t
|
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
} {}
test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} {
package forget t
package ifneeded t 2.3 x
package ifneeded t 2.4 y
package versions t
} {2.3 2.4}
| | > > > | | > > > > > > > > > > > > > > > | | | | 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 |
} {}
test pkg-3.46 {Tcl_PackageCmd procedure, "versions" option} {
package forget t
package ifneeded t 2.3 x
package ifneeded t 2.4 y
package versions t
} {2.3 2.4}
test pkg-3.47 {Tcl_PackageCmd procedure, "vsatisfies" option} !tip268 {
list [catch {package vsatisfies a} msg] $msg
} {1 {wrong # args: should be "package vsatisfies version1 version2"}}
test pkg-3.47-268 {Tcl_PackageCmd procedure, "vsatisfies" option} tip268 {
list [catch {package vsatisfies a} msg] $msg
} {1 {wrong # args: should be "package vsatisfies version requirement requirement..."}}
test pkg-3.48 {Tcl_PackageCmd procedure, "vsatisfies" option} !tip268 {
list [catch {package vsatisfies a b c} msg] $msg
} {1 {wrong # args: should be "package vsatisfies version1 version2"}}
test pkg-3.49 {Tcl_PackageCmd procedure, "vsatisfies" option} {
list [catch {package vsatisfies x.y 3.4} msg] $msg
} {1 {expected version number but got "x.y"}}
test pkg-3.50 {Tcl_PackageCmd procedure, "vsatisfies" option} {
list [catch {package vcompare 2.1 a.b} msg] $msg
} {1 {expected version number but got "a.b"}}
test pkg-3.51 {Tcl_PackageCmd procedure, "vsatisfies" option} {
package vs 2.3 2.1
} {1}
test pkg-3.52 {Tcl_PackageCmd procedure, "vsatisfies" option} {
package vs 2.3 1.2
} {0}
test pkg-3.53 {Tcl_PackageCmd procedure, "versions" option} !tip268 {
list [catch {package foo} msg] $msg
} {1 {bad option "foo": must be forget, ifneeded, names, present, provide, require, unknown, vcompare, versions, or vsatisfies}}
test pkg-3.53-268 {Tcl_PackageCmd procedure, "versions" option} tip268 {
list [catch {package foo} msg] $msg
} {1 {bad option "foo": must be forget, ifneeded, names, prefer, present, provide, require, unknown, vcompare, versions, or vsatisfies}}
test pkg-3.54 {Tcl_PackageCmd procedure, "vsatisfies" option} tip268 {
list [catch {package vsatisfies 2.1 2.1-3.2-4.5} msg] $msg
} {1 {expected versionMin-versionMax but got "2.1-3.2-4.5"}}
test pkg-3.55 {Tcl_PackageCmd procedure, "vsatisfies" option} tip268 {
list [catch {package vsatisfies 2.1 3.2-x.y} msg] $msg
} {1 {expected version number but got "x.y"}}
test pkg-3.56 {Tcl_PackageCmd procedure, "vsatisfies" option} tip268 {
list [catch {package vsatisfies 2.1 x.y-3.2} msg] $msg
} {1 {expected version number but got "x.y"}}
# No tests for FindPackage; can't think up anything detectable
# errors.
test pkg-4.1 {TclFreePackageInfo procedure} {
interp create foo
foo eval {
package ifneeded t 2.3 x
package ifneeded t 2.4 y
package ifneeded x 3.1 z
package provide q 4.3
package unknown "will this get freed?"
}
interp delete foo
} {}
test pkg-4.2 {TclFreePackageInfo procedure} -body {
interp create foo
foo eval {
package ifneeded t 2.3 x
package ifneeded t 2.4 y
package ifneeded x 3.1 z
package provide q 4.3
}
foo alias z kill
proc kill {} {
interp delete foo
}
foo eval package require x 3.1
} -returnCodes error -match glob -result *
test pkg-5.1 {CheckVersion procedure} {
list [catch {package vcompare 1 2.1} msg] $msg
} {0 -1}
test pkg-5.2 {CheckVersion procedure} {
list [catch {package vcompare .1 2.1} msg] $msg
} {1 {expected version number but got ".1"}}
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 |
} {1 {expected version number but got "a.b"}}
test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} {
list [catch {package present -exact x} msg] $msg
} {1 {wrong # args: should be "package present ?-exact? package ?version?"}}
test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} {
list [catch {package present -exact} msg] $msg
} {1 {wrong # args: should be "package present ?-exact? package ?version?"}}
set auto_path $oldPath
package unknown $oldPkgUnknown
concat
}
# cleanup
interp delete $i
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < | 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 |
} {1 {expected version number but got "a.b"}}
test pkg-7.17 {Tcl_PackageCmd procedure, "present" option} {
list [catch {package present -exact x} msg] $msg
} {1 {wrong # args: should be "package present ?-exact? package ?version?"}}
test pkg-7.18 {Tcl_PackageCmd procedure, "present" option} {
list [catch {package present -exact} msg] $msg
} {1 {wrong # args: should be "package present ?-exact? package ?version?"}}
# Note: It is correct that the result of the very first test,
# i.e. "5.0 5.0a0" is 1, i.e. that version 5.0a0 satisfies a 5.0
# requirement.
# The requirement "5.0" internally translates first to "5.0-6", and
# then to its final form of "5.0a0-6a0". These translations are
# explicitly specified by the TIP (Search for "padded/extended
# internally with 'a0'"). This was done intentionally for exactly the
# tested case, that an alpha package can satisfy a requirement for the
# regular package. An example would be a package FOO requiring Tcl 8.X
# for its operation. It can be used with Tcl 8.Xa0. Without our
# translation that would not be possible.
set n 0
foreach {r p vs vc} {
5.0 5.0a0 1 1
5.0a0 5.0 1 -1
8.5a0 8.5a5 1 -1
8.5a0 8.5b1 1 -1
8.5a0 8.5.1 1 -1
8.5a0 8.6a0 1 -1
8.5a0 8.6b0 1 -1
8.5a0 8.6.0 1 -1
8.5a6 8.5a5 0 1
8.5a6 8.5b1 1 -1
8.5a6 8.5.1 1 -1
8.5a6 8.6a0 1 -1
8.5a6 8.6b0 1 -1
8.5a6 8.6.0 1 -1
8.5b0 8.5a5 0 1
8.5b0 8.5b1 1 -1
8.5b0 8.5.1 1 -1
8.5b0 8.6a0 1 -1
8.5b0 8.6b0 1 -1
8.5b0 8.6.0 1 -1
8.5b2 8.5a5 0 1
8.5b2 8.5b1 0 1
8.5b2 8.5.1 1 -1
8.5b2 8.6a0 1 -1
8.5b2 8.6b0 1 -1
8.5b2 8.6.0 1 -1
8.5 8.5a5 1 1
8.5 8.5b1 1 1
8.5 8.5.1 1 -1
8.5 8.6a0 1 -1
8.5 8.6b0 1 -1
8.5 8.6.0 1 -1
8.5.0 8.5a5 0 1
8.5.0 8.5b1 0 1
8.5.0 8.5.1 1 -1
8.5.0 8.6a0 1 -1
8.5.0 8.6b0 1 -1
8.5.0 8.6.0 1 -1
} {
test package-vsatisfies-1.$n {package vsatisfies} tip268 {
package vsatisfies $p $r
} $vs
test package-vcompare-1.$n {package vcompare} tip268 {
package vcompare $r $p
} $vc
incr n
}
set n 0
foreach {required provided satisfied} {
8.5a0- 8.5a5 1
8.5a0- 8.5b1 1
8.5a0- 8.5.1 1
8.5a0- 8.6a0 1
8.5a0- 8.6b0 1
8.5a0- 8.6.0 1
8.5a6- 8.5a5 0
8.5a6- 8.5b1 1
8.5a6- 8.5.1 1
8.5a6- 8.6a0 1
8.5a6- 8.6b0 1
8.5a6- 8.6.0 1
8.5b0- 8.5a5 0
8.5b0- 8.5b1 1
8.5b0- 8.5.1 1
8.5b0- 8.6a0 1
8.5b0- 8.6b0 1
8.5b0- 8.6.0 1
8.5b2- 8.5a5 0
8.5b2- 8.5b1 0
8.5b2- 8.5.1 1
8.5b2- 8.6a0 1
8.5b2- 8.6b0 1
8.5b2- 8.6.0 1
8.5- 8.5a5 1
8.5- 8.5b1 1
8.5- 8.5.1 1
8.5- 8.6a0 1
8.5- 8.6b0 1
8.5- 8.6.0 1
8.5.0- 8.5a5 0
8.5.0- 8.5b1 0
8.5.0- 8.5.1 1
8.5.0- 8.6a0 1
8.5.0- 8.6b0 1
8.5.0- 8.6.0 1
8.5a0-7 8.5a5 0
8.5a0-7 8.5b1 0
8.5a0-7 8.5.1 0
8.5a0-7 8.6a0 0
8.5a0-7 8.6b0 0
8.5a0-7 8.6.0 0
8.5a6-7 8.5a5 0
8.5a6-7 8.5b1 0
8.5a6-7 8.5.1 0
8.5a6-7 8.6a0 0
8.5a6-7 8.6b0 0
8.5a6-7 8.6.0 0
8.5b0-7 8.5a5 0
8.5b0-7 8.5b1 0
8.5b0-7 8.5.1 0
8.5b0-7 8.6a0 0
8.5b0-7 8.6b0 0
8.5b0-7 8.6.0 0
8.5b2-7 8.5a5 0
8.5b2-7 8.5b1 0
8.5b2-7 8.5.1 0
8.5b2-7 8.6a0 0
8.5b2-7 8.6b0 0
8.5b2-7 8.6.0 0
8.5-7 8.5a5 0
8.5-7 8.5b1 0
8.5-7 8.5.1 0
8.5-7 8.6a0 0
8.5-7 8.6b0 0
8.5-7 8.6.0 0
8.5.0-7 8.5a5 0
8.5.0-7 8.5b1 0
8.5.0-7 8.5.1 0
8.5.0-7 8.6a0 0
8.5.0-7 8.6b0 0
8.5.0-7 8.6.0 0
8.5a0-8.6.1 8.5a5 1
8.5a0-8.6.1 8.5b1 1
8.5a0-8.6.1 8.5.1 1
8.5a0-8.6.1 8.6a0 1
8.5a0-8.6.1 8.6b0 1
8.5a0-8.6.1 8.6.0 1
8.5a6-8.6.1 8.5a5 0
8.5a6-8.6.1 8.5b1 1
8.5a6-8.6.1 8.5.1 1
8.5a6-8.6.1 8.6a0 1
8.5a6-8.6.1 8.6b0 1
8.5a6-8.6.1 8.6.0 1
8.5b0-8.6.1 8.5a5 0
8.5b0-8.6.1 8.5b1 1
8.5b0-8.6.1 8.5.1 1
8.5b0-8.6.1 8.6a0 1
8.5b0-8.6.1 8.6b0 1
8.5b0-8.6.1 8.6.0 1
8.5b2-8.6.1 8.5a5 0
8.5b2-8.6.1 8.5b1 0
8.5b2-8.6.1 8.5.1 1
8.5b2-8.6.1 8.6a0 1
8.5b2-8.6.1 8.6b0 1
8.5b2-8.6.1 8.6.0 1
8.5-8.6.1 8.5a5 1
8.5-8.6.1 8.5b1 1
8.5-8.6.1 8.5.1 1
8.5-8.6.1 8.6a0 1
8.5-8.6.1 8.6b0 1
8.5-8.6.1 8.6.0 1
8.5.0-8.6.1 8.5a5 0
8.5.0-8.6.1 8.5b1 0
8.5.0-8.6.1 8.5.1 1
8.5.0-8.6.1 8.6a0 1
8.5.0-8.6.1 8.6b0 1
8.5.0-8.6.1 8.6.0 1
8.5a0-8.5a0 8.5a0 1
8.5a0-8.5a0 8.5b1 0
8.5a0-8.5a0 8.4 0
8.5b0-8.5b0 8.5a5 0
8.5b0-8.5b0 8.5b0 1
8.5b0-8.5b0 8.5.1 0
8.5-8.5 8.5a5 0
8.5-8.5 8.5b1 0
8.5-8.5 8.5 1
8.5-8.5 8.5.1 0
8.5.0-8.5.0 8.5a5 0
8.5.0-8.5.0 8.5b1 0
8.5.0-8.5.0 8.5.0 1
8.5.0-8.5.0 8.5.1 0
8.5.0-8.5.0 8.6a0 0
8.5.0-8.5.0 8.6b0 0
8.5.0-8.5.0 8.6.0 0
8.2 9 0
8.2- 9 1
8.2-8.5 9 0
8.2-9.1 9 1
8.5-8.5 8.5b1 0
8.5a0-8.5 8.5b1 0
8.5a0-8.5.1 8.5b1 1
8.5-8.5 8.5 1
8.5.0-8.5.0 8.5 1
8.5a0-8.5.0 8.5 0
} {
test package-vsatisfies-2.$n "package vsatisfies $provided $required" tip268 {
package vsatisfies $provided $required
} $satisfied
incr n
}
test package-vsatisfies-3.0 "package vsatisfies multiple" tip268 {
# yes no
package vsatisfies 8.4 8.4 7.3
} 1
test package-vsatisfies-3.1 "package vsatisfies multiple" tip268 {
# no yes
package vsatisfies 8.4 7.3 8.4
} 1
test package-vsatisfies-3.2 "package vsatisfies multiple" tip268 {
# yes yes
package vsatisfies 8.4.2 8.4 8.4.1
} 1
test package-vsatisfies-3.3 "package vsatisfies multiple" tip268 {
# no no
package vsatisfies 8.4 7.3 6.1
} 0
proc prefer {args} {
set ip [interp create]
lappend res [$ip eval {package prefer}]
foreach mode $args {
lappend res [$ip eval [list package prefer $mode]]
}
interp delete $ip
return $res
}
test package-prefer-1.0 {default} tip268 {
prefer
} stable
test package-prefer-1.1 {default} tip268 {
set ::env(TCL_PKG_PREFER_LATEST) stable ; # value not relevant!
set res [prefer]
unset ::env(TCL_PKG_PREFER_LATEST)
set res
} latest
test package-prefer-2.0 {wrong\#args} tip268 {
catch {package prefer foo bar} msg
set msg
} {wrong # args: should be "package prefer ?latest|stable?"}
test package-prefer-2.1 {bogus argument} tip268 {
catch {package prefer foo} msg
set msg
} {bad preference "foo": must be latest or stable}
test package-prefer-3.0 {set, keep} tip268 {
package prefer stable
} stable
test package-prefer-3.1 {set stable, keep} tip268 {
prefer stable
} {stable stable}
test package-prefer-3.2 {set latest, change} tip268 {
prefer latest
} {stable latest}
test package-prefer-3.3 {set latest, keep} tip268 {
prefer latest latest
} {stable latest latest}
test package-prefer-3.4 {set stable, rejected} tip268 {
prefer latest stable
} {stable latest latest}
rename prefer {}
set auto_path $oldPath
package unknown $oldPkgUnknown
concat
cleanupTests
}
# cleanup
interp delete $i
::tcltest::cleanupTests
return
|
Changes to tests/pkgMkIndex.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains tests for the pkg_mkIndex command. # Note that the tests are limited to Tcl scripts only, there are no shared # libraries against which to test. # # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
# This file contains tests for the pkg_mkIndex command.
# Note that the tests are limited to Tcl scripts only, there are no shared
# libraries against which to test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
# RCS: @(#) $Id: pkgMkIndex.test,v 1.23.2.1 2003/07/24 08:23:39 rmax Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
set fullPkgPath [makeDirectory pkg]
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 287 288 289 290 291 292 293 |
test pkgMkIndex-2.2 {simple package - use -direct} {
pkgtest::runIndex -direct $fullPkgPath simple.tcl
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"
test pkgMkIndex-2.3 {simple package - direct loading is default} {
pkgtest::runIndex $fullPkgPath simple.tcl
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"
removeFile [file join pkg simple.tcl]
makeFile {
# Contains global symbols, used to check that they don't have a leading ::
package provide global 1.0
proc global_lower { stg } {
| > > > > > > > > | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 |
test pkgMkIndex-2.2 {simple package - use -direct} {
pkgtest::runIndex -direct $fullPkgPath simple.tcl
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"
test pkgMkIndex-2.3 {simple package - direct loading is default} {
pkgtest::runIndex $fullPkgPath simple.tcl
} "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}"
test pkgMkIndex-2.4 {simple package - use -verbose} -body {
pkgtest::runIndex -verbose $fullPkgPath simple.tcl
} -result "0 {{simple:1.0 {[list source [file join $fullPkgPath simple.tcl]]}}}" \
-errorOutput {successful sourcing of simple.tcl
packages provided were {simple 1.0}
processed simple.tcl
}
removeFile [file join pkg simple.tcl]
makeFile {
# Contains global symbols, used to check that they don't have a leading ::
package provide global 1.0
proc global_lower { stg } {
|
| ︙ | ︙ |
Changes to tests/platform.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
# RCS: @(#)
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
} {byteOrder machine os osVersion platform user wordSize}
# Test assumes twos-complement arithmetic, which is true of virtually
# everything these days. Note that this does *not* use wide(), and
# this is intentional since that could make Tcl's numbers wider than
# the machine-integer on some platforms...
test platform-2.1 {tcl_platform(wordSize) indicates size of native word} {
set result [expr {1 << (8 * $tcl_platform(wordSize) - 1)}]
# Result must be the largest bit in a machine word, which this checks
# without assuming how wide the word really is
list [expr {$result < 0}] [expr {$result ^ ($result - 1)}]
} {1 -1}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
# RCS: @(#)
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testWinCPUID [llength [info commands testwincpuid]]
test platform-1.1 {TclpSetVariables: tcl_platform} {
interp create i
i eval {catch {unset tcl_platform(debug)}}
i eval {catch {unset tcl_platform(threaded)}}
i eval {catch {unset tcl_platform(tip,268)}}
i eval {catch {unset tcl_platform(tip,280)}}
set result [i eval {lsort [array names tcl_platform]}]
interp delete i
set result
} {byteOrder machine os osVersion platform user wordSize}
# Test assumes twos-complement arithmetic, which is true of virtually
# everything these days. Note that this does *not* use wide(), and
# this is intentional since that could make Tcl's numbers wider than
# the machine-integer on some platforms...
test platform-2.1 {tcl_platform(wordSize) indicates size of native word} {
set result [expr {1 << (8 * $tcl_platform(wordSize) - 1)}]
# Result must be the largest bit in a machine word, which this checks
# without assuming how wide the word really is
list [expr {$result < 0}] [expr {$result ^ ($result - 1)}]
} {1 -1}
# On Windows, test that the CPU ID works
test platform-3.1 {CPU ID on Windows } \
-constraints testWinCPUID \
-body {
set cpudata [testwincpuid 0]
binary format iii \
[lindex $cpudata 1] \
[lindex $cpudata 3] \
[lindex $cpudata 2]
} \
-match regexp \
-result {^(?:AuthenticAMD|CentaurHauls|CyrixInstead|GenuineIntel)$}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/proc-old.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: proc-old.test,v 1.9.2.1 2003/03/27 21:46:32 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {rename t1 ""}
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
}
set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
while executing
"tproc2"} none}
| | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 |
}
set msg [list [catch tproc2 msg] $msg $errorInfo $errorCode]
regsub -all [file join {} _bad_file_name] $msg "_bad_file_name" msg
normalizeMsg $msg
} {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
while executing
"tproc2"} none}
test proc-old-7.15 {return with special completion code} {
list [catch {return -badOption foo message} msg] $msg
} {1 {bad option "-badOption": must be -code, -errorcode, or -errorinfo}}
test proc-old-8.1 {unset and undefined local arrays} {
proc t1 {} {
foreach v {xxx, yyy} {
catch {unset $v}
|
| ︙ | ︙ |
Changes to tests/proc.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: proc.test,v 1.11.2.1 2004/05/02 21:07:16 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {eval namespace delete [namespace children :: test_ns_*]}
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
list [p] [namespace which p]
}
} {{p in ::} ::p}
test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
proc p {x} {info commands 3m}
list [catch {p} msg] $msg
} {1 {wrong # args: should be "p x"}}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
if {[catch {package require procbodytest}]} {
puts "This application couldn't load the \"procbodytest\" package, so I"
puts "can't test creation of procs whose bodies have type \"procbody\"."
::tcltest::cleanupTests
return
| > > > > > > | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 |
list [p] [namespace which p]
}
} {{p in ::} ::p}
test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
proc p {x} {info commands 3m}
list [catch {p} msg] $msg
} {1 {wrong # args: should be "p x"}}
test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} {
proc {a b c} {x} {info commands 3m}
list [catch {{a b c}} msg] $msg
} {1 {wrong # args: should be "{a b c} x"}}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {rename {a b c} {}}
catch {unset msg}
if {[catch {package require procbodytest}]} {
puts "This application couldn't load the \"procbodytest\" package, so I"
puts "can't test creation of procs whose bodies have type \"procbody\"."
::tcltest::cleanupTests
return
|
| ︙ | ︙ |
Changes to tests/reg.test.
1 2 3 4 5 6 7 8 9 10 11 | # reg.test -- # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # (Don't panic if you are seeing this as part of the reg distribution # and aren't using Tcl -- reg's own regression tester also knows how # to read this file, ignoring the Tcl-isms.) # # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# reg.test --
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
# (Don't panic if you are seeing this as part of the reg distribution
# and aren't using Tcl -- reg's own regression tester also knows how
# to read this file, ignoring the Tcl-isms.)
#
# Copyright (c) 1998, 1999 Henry Spencer. All rights reserved.
#
# RCS: @(#) $Id: reg.test,v 1.16.2.3 2004/11/27 05:44:13 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# All tests require the testregexp command, return if this
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
set prefix reg-$major
set description "reg $desc"
set testbypassed 0
}
# build test number (internal)
proc tno {testid} {
| | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
set prefix reg-$major
set description "reg $desc"
set testbypassed 0
}
# build test number (internal)
proc tno {testid} {
return [join $testid .]
}
# build description, with possible modifiers (internal)
proc desc {testid} {
global description
set d $description
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 997 998 999 1000 |
# Tests resulting from bugs reported by users
test reg-31.1 {[[:xdigit:]] behaves correctly when followed by [[:space:]]} {
set str {2:::DebugWin32}
set re {([[:xdigit:]])([[:space:]]*)}
list [regexp $re $str match xdigit spaces] $match $xdigit $spaces
# Code used to produce {1 2:::DebugWin32 2 :::DebugWin32} !!!
} {1 2 2 {}}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 |
# Tests resulting from bugs reported by users
test reg-31.1 {[[:xdigit:]] behaves correctly when followed by [[:space:]]} {
set str {2:::DebugWin32}
set re {([[:xdigit:]])([[:space:]]*)}
list [regexp $re $str match xdigit spaces] $match $xdigit $spaces
# Code used to produce {1 2:::DebugWin32 2 :::DebugWin32} !!!
} {1 2 2 {}}
test reg-32.1 {canmatch functionality -- at end} testregexp {
set pat {blah}
set line "asd asd"
# can match at the final d, if '%' follows
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 7}
test reg-32.2 {canmatch functionality -- at end} testregexp {
set pat {s%$}
set line "asd asd"
# can only match after the end of the string
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 7}
test reg-32.3 {canmatch functionality -- not last char} testregexp {
set pat {[^d]%$}
set line "asd asd"
# can only match after the end of the string
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 7}
test reg-32.3.1 {canmatch functionality -- no match} testregexp {
set pat {\Zx}
set line "asd asd"
# can match the last char, if followed by x
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 -1}
test reg-32.4 {canmatch functionality -- last char} {knownBug} {
set pat {.x}
set line "asd asd"
# can match the last char, if followed by x
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 6}
test reg-32.4.1 {canmatch functionality -- last char} {knownBug} {
set pat {.x$}
set line "asd asd"
# can match the last char, if followed by x
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 6}
test reg-32.5 {canmatch functionality -- last char} {knownBug} {
set pat {.[^d]x$}
set line "asd asd"
# can match the last char, if followed by not-d and x.
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 6}
test reg-32.6 {canmatch functionality -- last char} {knownBug} {
set pat {[^a]%[^\r\n]*$}
set line "asd asd"
# can match at the final d, if '%' follows
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 6}
test reg-32.7 {canmatch functionality -- last char} {knownBug} {
set pat {[^a]%$}
set line "asd asd"
# can match at the final d, if '%' follows
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 6}
test reg-32.8 {canmatch functionality -- last char} {knownBug} {
set pat {[^x]%$}
set line "asd asd"
# can match at the final d, if '%' follows
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 6}
test reg-32.9 {canmatch functionality -- more complex case} {knownBug} {
set pat {((\B\B|\Bh+line)[ \t]*|[^\B]%[^\r\n]*)$}
set line "asd asd"
# can match at the final d, if '%' follows
set res [testregexp -xflags -- c $pat $line resvar]
lappend res $resvar
} {0 6}
# Tests reg-33.*: Checks for bug fixes
test reg-33.1 {Bug 230589} {
regexp {[ ]*(^|[^%])%V} "*%V2" m s
} 1
test reg-33.2 {Bug 504785} {
regexp -inline {([^_.]*)([^.]*)\.(..)(.).*} bbcos_001_c01.q1la
} {bbcos_001_c01.q1la bbcos _001_c01 q1 l}
test reg-33.3 {Bug 505048} {
regexp {\A\s*[^<]*\s*<([^>]+)>} a<a>
} 1
test reg-33.4 {Bug 505048} {
regexp {\A\s*([^b]*)b} ab
} 1
test reg-33.5 {Bug 505048} {
regexp {\A\s*[^b]*(b)} ab
} 1
test reg-33.6 {Bug 505048} {
regexp {\A(\s*)[^b]*(b)} ab
} 1
test reg-33.7 {Bug 505048} {
regexp {\A\s*[^b]*b} ab
} 1
test reg-33.8 {Bug 505048} {
regexp -inline {\A\s*[^b]*b} ab
} ab
test reg-33.9 {Bug 505048} {
regexp -indices -inline {\A\s*[^b]*b} ab
} {{0 1}}
test reg-33.10 {Bug 840258} {
regsub {(^|\n)+\.*b} \n.b {} tmp
} 1
test reg-33.11 {Bug 840258} {
regsub {(^|[\n\r]+)\.*\?<.*?(\n|\r)+} \
"TQ\r\n.?<5000267>Test already stopped\r\n" {} tmp
} 1
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/regexp.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: regexp, regsub # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1998 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# Commands covered: regexp, regsub
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: regexp.test,v 1.22.2.3 2003/10/14 18:22:10 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset foo}
test regexp-1.1 {basic regexp operation} {
regexp ab*c abbbc
} 1
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 |
regexp .*e f
set x .
append x *a
regexp -nocase $x bbba
} 1
testConstraint exec [llength [info commands exec]]
| | | | | > > > > | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 |
regexp .*e f
set x .
append x *a
regexp -nocase $x bbba
} 1
testConstraint exec [llength [info commands exec]]
test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -constraints {
exec
} -setup {
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
test regexp-15.1 {regexp -start} {
catch {unset x}
list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexp-15.2 {regexp -start} {
catch {unset x}
|
| ︙ | ︙ | |||
567 568 569 570 571 572 573 574 575 576 577 |
set c abcdefghijklmnopqurstuvwxyz0123456789
regsub $a $c $b d
list $d [string length $d] [string bytelength $d]
} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexp-20.2 {regsub shared object shimmering with -about} {
eval regexp -about abc
} {0 {}}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 |
set c abcdefghijklmnopqurstuvwxyz0123456789
regsub $a $c $b d
list $d [string length $d] [string bytelength $d]
} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexp-20.2 {regsub shared object shimmering with -about} {
eval regexp -about abc
} {0 {}}
test regexp-21.1 {regsub works with empty string} {
regsub -- ^ {} foo
} {foo}
test regexp-21.2 {regsub works with empty string} {
regsub -- \$ {} foo
} {foo}
test regexp-21.3 {regsub works with empty string offset} {
regsub -start 0 -- ^ {} foo
} {foo}
test regexp-21.4 {regsub works with empty string offset} {
regsub -start 0 -- \$ {} foo
} {foo}
test regexp-21.5 {regsub works with empty string offset} {
regsub -start 3 -- \$ {123} foo
} {123foo}
test regexp-21.6 {regexp works with empty string} {
regexp -- ^ {}
} {1}
test regexp-21.7 {regexp works with empty string} {
regexp -start 0 -- ^ {}
} {1}
test regexp-21.8 {regexp works with empty string offset} {
regexp -start 3 -- ^ {123}
} {0}
test regexp-21.9 {regexp works with empty string offset} {
regexp -start 3 -- \$ {123}
} {1}
test regexp-21.10 {multiple matches handle newlines} {
regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
} "foo\nfoo\nfoo\n"
test regexp-21.11 {multiple matches handle newlines} {
regsub -all -line -- ^ "a\nb\nc" \#
} "\#a\n\#b\n\#c"
test regexp-21.12 {multiple matches handle newlines} {
regsub -all -line -- ^ "\n\n" \#
} "\#\n\#\n\#"
test regexp-21.13 {multiple matches handle newlines} {
regexp -all -inline -indices -line -- ^ "a\nb\nc"
} {{0 -1} {2 1} {4 3}}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/regexpComp.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id$
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Procedure to evaluate a script within a proc, to test compilation
# functionality
proc evalInProc { script } {
proc testProc {} $script
set status [catch {
testProc
} result]
rename testProc {}
return $result
#return [list $status $result]
}
catch {unset foo}
test regexpComp-1.1 {basic regexp operation} {
evalInProc {
regexp ab*c abbbc
}
} 1
test regexpComp-1.2 {basic regexp operation} {
evalInProc {
regexp ab*c ac
}
} 1
test regexpComp-1.3 {basic regexp operation} {
evalInProc {
regexp ab*c ab
}
} 0
test regexpComp-1.4 {basic regexp operation} {
evalInProc {
regexp -- -gorp abc-gorpxxx
}
} 1
test regexpComp-1.5 {basic regexp operation} {
evalInProc {
regexp {^([^ ]*)[ ]*([^ ]*)} "" a
}
} 1
test regexpComp-1.6 {basic regexp operation} {
list [catch {regexp {} abc} msg] $msg
} {0 1}
test regexpComp-1.7 {regexp utf compliance} {
# if not UTF-8 aware, result is "0 1"
evalInProc {
set foo "\u4e4eb q"
regexp "\u4e4eb q" "a\u4e4eb qw\u5e4e\x4e wq" bar
list [string compare $foo $bar] [regexp 4 $bar]
}
} {0 0}
test regexpComp-2.1 {getting substrings back from regexp} {
evalInProc {
set foo {}
list [regexp ab*c abbbbc foo] $foo
}
} {1 abbbbc}
test regexpComp-2.2 {getting substrings back from regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp a(b*)c abbbbc foo f2] $foo $f2
}
} {1 abbbbc bbbb}
test regexpComp-2.3 {getting substrings back from regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp a(b*)(c) abbbbc foo f2] $foo $f2
}
} {1 abbbbc bbbb}
test regexpComp-2.4 {getting substrings back from regexp} {
evalInProc {
set foo {}
set f2 {}
set f3 {}
list [regexp a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
}
} {1 abbbbc bbbb c}
test regexpComp-2.5 {getting substrings back from regexp} {
evalInProc {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}; set fa {}; set fb {};
list [regexp (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*)(a*)(b*) \
12223345556789999aabbb \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9 fa fb] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9 $fa $fb
}
} {1 12223345556789999aabbb 1 222 33 4 555 6 7 8 9999 aa bbb}
test regexpComp-2.6 {getting substrings back from regexp} {
evalInProc {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 a a {} {}}
test regexpComp-2.7 {getting substrings back from regexp} {
evalInProc {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 ac a {} c}
test regexpComp-2.8 {getting substrings back from regexp} {
evalInProc {
set match {}
list [regexp {^a*b} aaaab match] $match
}
} {1 aaaab}
test regexpComp-3.1 {-indices option to regexp} {
evalInProc {
set foo {}
list [regexp -indices ab*c abbbbc foo] $foo
}
} {1 {0 5}}
test regexpComp-3.2 {-indices option to regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp -indices a(b*)c abbbbc foo f2] $foo $f2
}
} {1 {0 5} {1 4}}
test regexpComp-3.3 {-indices option to regexp} {
evalInProc {
set foo {}
set f2 {}
list [regexp -indices a(b*)(c) abbbbc foo f2] $foo $f2
}
} {1 {0 5} {1 4}}
test regexpComp-3.4 {-indices option to regexp} {
evalInProc {
set foo {}
set f2 {}
set f3 {}
list [regexp -indices a(b*)(c) abbbbc foo f2 f3] $foo $f2 $f3
}
} {1 {0 5} {1 4} {5 5}}
test regexpComp-3.5 {-indices option to regexp} {
evalInProc {
set foo {}; set f1 {}; set f2 {}; set f3 {}; set f4 {}; set f5 {};
set f6 {}; set f7 {}; set f8 {}; set f9 {}
list [regexp -indices (1*)(2*)(3*)(4*)(5*)(6*)(7*)(8*)(9*) \
12223345556789999 \
foo f1 f2 f3 f4 f5 f6 f7 f8 f9] $foo $f1 $f2 $f3 $f4 $f5 \
$f6 $f7 $f8 $f9
}
} {1 {0 16} {0 0} {1 3} {4 5} {6 6} {7 9} {10 10} {11 11} {12 12} {13 16}}
test regexpComp-3.6 {getting substrings back from regexp} {
evalInProc {
set foo 2; set f2 2; set f3 2; set f4 2
list [regexp -indices (a)(b)? xay foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 {1 1} {1 1} {-1 -1} {-1 -1}}
test regexpComp-3.7 {getting substrings back from regexp} {
evalInProc {
set foo 1; set f2 1; set f3 1; set f4 1
list [regexp -indices (a)(b)?(c) xacy foo f2 f3 f4] $foo $f2 $f3 $f4
}
} {1 {1 2} {1 1} {-1 -1} {2 2}}
test regexpComp-4.1 {-nocase option to regexp} {
evalInProc {
regexp -nocase foo abcFOo
}
} 1
test regexpComp-4.2 {-nocase option to regexp} {
evalInProc {
set f1 22
set f2 33
set f3 44
list [regexp -nocase {a(b*)([xy]*)z} aBbbxYXxxZ22 f1 f2 f3] $f1 $f2 $f3
}
} {1 aBbbxYXxxZ Bbb xYXxx}
test regexpComp-4.3 {-nocase option to regexp} {
evalInProc {
regexp -nocase FOo abcFOo
}
} 1
set ::x abcdefghijklmnopqrstuvwxyz1234567890
set ::x $x$x$x$x$x$x$x$x$x$x$x$x
test regexpComp-4.4 {case conversion in regexp} {
evalInProc {
list [regexp -nocase $::x $::x foo] $foo
}
} "1 $x"
catch {unset ::x}
test regexpComp-5.1 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*a bbba
}
} 1
test regexpComp-5.2 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*b xxxb
}
} 1
test regexpComp-5.3 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*c yyyc
}
} 1
test regexpComp-5.4 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*d 1d
}
} 1
test regexpComp-5.5 {exercise cache of compiled expressions} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
regexp .*e xe
}
} 1
test regexpComp-6.1 {regexp errors} {
evalInProc {
list [catch {regexp a} msg] $msg
}
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
test regexpComp-6.2 {regexp errors} {
evalInProc {
list [catch {regexp -nocase a} msg] $msg
}
} {1 {wrong # args: should be "regexp ?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"}}
test regexpComp-6.3 {regexp errors} {
evalInProc {
list [catch {regexp -gorp a} msg] $msg
}
} {1 {bad switch "-gorp": must be -all, -about, -indices, -inline, -expanded, -line, -linestop, -lineanchor, -nocase, -start, or --}}
test regexpComp-6.4 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.5 {regexp errors} {
evalInProc {
list [catch {regexp a( b} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-6.6 {regexp errors} {
evalInProc {
list [catch {regexp a a f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1 f1} msg] $msg
}
} {0 1}
test regexpComp-6.7 {regexp errors} {
evalInProc {
list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
}
} {0 0}
test regexpComp-6.8 {regexp errors} {
evalInProc {
catch {unset f1}
set f1 44
list [catch {regexp abc abc f1(f2)} msg] $msg
}
} {1 {couldn't set variable "f1(f2)"}}
test regexpComp-6.9 {regexp errors, -start bad int check} {
evalInProc {
list [catch {regexp -start bogus {^$} {}} msg] $msg
}
} {1 {expected integer but got "bogus"}}
test regexpComp-7.1 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaaxaa 111&222 foo] $foo
}
} {1 xax111aaa222xaa}
test regexpComp-7.2 {basic regsub operation} {
evalInProc {
list [regsub aa+ aaaxaa &111 foo] $foo
}
} {1 aaa111xaa}
test regexpComp-7.3 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaa 111& foo] $foo
}
} {1 xax111aaa}
test regexpComp-7.4 {basic regsub operation} {
evalInProc {
list [regsub aa+ aaa 11&2&333 foo] $foo
}
} {1 11aaa2aaa333}
test regexpComp-7.5 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaaxaa &2&333 foo] $foo
}
} {1 xaxaaa2aaa333xaa}
test regexpComp-7.6 {basic regsub operation} {
evalInProc {
list [regsub aa+ xaxaaaxaa 1&22& foo] $foo
}
} {1 xax1aaa22aaaxaa}
test regexpComp-7.7 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\122\1} foo] $foo
}
} {1 xax1aa22aaxaa}
test regexpComp-7.8 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\\\122\1} foo] $foo
}
} "1 {xax1\\aa22aaxaa}"
test regexpComp-7.9 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\\122\1} foo] $foo
}
} "1 {xax1\\122aaxaa}"
test regexpComp-7.10 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\\&\1} foo] $foo
}
} "1 {xax1\\aaaaaxaa}"
test regexpComp-7.11 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {1\&\1} foo] $foo
}
} {1 xax1&aaxaa}
test regexpComp-7.12 {basic regsub operation} {
evalInProc {
list [regsub a(a+) xaxaaaxaa {\1\1\1\1&&} foo] $foo
}
} {1 xaxaaaaaaaaaaaaaaxaa}
test regexpComp-7.13 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub abc xyz 111 foo] $foo
}
} {0 xyz}
test regexpComp-7.14 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub ^ xyz "111 " foo] $foo
}
} {1 {111 xyz}}
test regexpComp-7.15 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub -- -foo abc-foodef "111 " foo] $foo
}
} {1 {abc111 def}}
test regexpComp-7.16 {basic regsub operation} {
evalInProc {
set foo xxx
list [regsub x "" y foo] $foo
}
} {0 {}}
test regexpComp-7.17 {regsub utf compliance} {
evalInProc {
# if not UTF-8 aware, result is "0 1"
set foo "xyz555ijka\u4e4ebpqr"
regsub a\u4e4eb xyza\u4e4ebijka\u4e4ebpqr 555 bar
list [string compare $foo $bar] [regexp 4 $bar]
}
} {0 0}
test regexpComp-8.1 {case conversion in regsub} {
evalInProc {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
}
} {1 xaAAaAAay}
test regexpComp-8.2 {case conversion in regsub} {
evalInProc {
list [regsub -nocase a(a+) xaAAaAAay & foo] $foo
}
} {1 xaAAaAAay}
test regexpComp-8.3 {case conversion in regsub} {
evalInProc {
set foo 123
list [regsub a(a+) xaAAaAAay & foo] $foo
}
} {0 xaAAaAAay}
test regexpComp-8.4 {case conversion in regsub} {
evalInProc {
set foo 123
list [regsub -nocase a CaDE b foo] $foo
}
} {1 CbDE}
test regexpComp-8.5 {case conversion in regsub} {
evalInProc {
set foo 123
list [regsub -nocase XYZ CxYzD b foo] $foo
}
} {1 CbD}
test regexpComp-8.6 {case conversion in regsub} {
evalInProc {
set x abcdefghijklmnopqrstuvwxyz1234567890
set x $x$x$x$x$x$x$x$x$x$x$x$x
set foo 123
list [regsub -nocase $x $x b foo] $foo
}
} {1 b}
test regexpComp-9.1 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub -all x+ axxxbxxcxdx |&| foo] $foo
}
} {4 a|xxx|b|xx|c|x|d|x|}
test regexpComp-9.2 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub -nocase -all x+ aXxXbxxcXdx |&| foo] $foo
}
} {4 a|XxX|b|xx|c|X|d|x|}
test regexpComp-9.3 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub x+ axxxbxxcxdx |&| foo] $foo
}
} {1 a|xxx|bxxcxdx}
test regexpComp-9.4 {-all option to regsub} {
evalInProc {
set foo 86
list [regsub -all bc axxxbxxcxdx |&| foo] $foo
}
} {0 axxxbxxcxdx}
test regexpComp-9.5 {-all option to regsub} {
evalInProc {
set foo xxx
list [regsub -all node "node node more" yy foo] $foo
}
} {2 {yy yy more}}
test regexpComp-9.6 {-all option to regsub} {
evalInProc {
set foo xxx
list [regsub -all ^ xxx 123 foo] $foo
}
} {1 123xxx}
test regexpComp-10.1 {expanded syntax in regsub} {
evalInProc {
set foo xxx
list [regsub -expanded ". \#comment\n . \#comment2" abc def foo] $foo
}
} {1 defc}
test regexpComp-10.2 {newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\n" 123 foo] $foo
}
} "1 {dabc\n123\n}"
test regexpComp-10.3 {newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -line {^a.*b$} "dabc\naxyb\nxb" 123 foo] $foo
}
} "1 {dabc\n123\nxb}"
test regexpComp-10.4 {partial newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -lineanchor {^a.*b$} "da\naxyb\nxb" 123 foo] $foo
}
} "1 {da\n123}"
test regexpComp-10.5 {inverse partial newline sensitivity in regsub} {
evalInProc {
set foo xxx
list [regsub -linestop {a.*b} "da\nbaxyb\nxb" 123 foo] $foo
}
} "1 {da\nb123\nxb}"
test regexpComp-11.1 {regsub errors} {
evalInProc {
list [catch {regsub a b} msg] $msg
}
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexpComp-11.2 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a b} msg] $msg
}
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexpComp-11.3 {regsub errors} {
evalInProc {
list [catch {regsub -nocase -all a b} msg] $msg
}
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexpComp-11.4 {regsub errors} {
evalInProc {
list [catch {regsub a b c d e f} msg] $msg
}
} {1 {wrong # args: should be "regsub ?switches? exp string subSpec ?varName?"}}
test regexpComp-11.5 {regsub errors} {
evalInProc {
list [catch {regsub -gorp a b c} msg] $msg
}
} {1 {bad switch "-gorp": must be -all, -nocase, -expanded, -line, -linestop, -lineanchor, -start, or --}}
test regexpComp-11.6 {regsub errors} {
evalInProc {
list [catch {regsub -nocase a( b c d} msg] $msg
}
} {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
test regexpComp-11.7 {regsub errors} {
evalInProc {
catch {unset f1}
set f1 44
list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
}
} {1 {couldn't set variable "f1(f2)"}}
test regexpComp-11.8 {regsub errors, -start bad int check} {
evalInProc {
list [catch {regsub -start bogus pattern string rep var} msg] $msg
}
} {1 {expected integer but got "bogus"}}
# This test crashes on the Mac unless you increase the Stack Space to about 1
# Meg. This is probably bigger than most users want...
# 8.2.3 regexp reduced stack space requirements, but this should be
# tested again
test regexpComp-12.1 {Tcl_RegExpExec: large number of subexpressions} {macCrash} {
evalInProc {
list [regexp (.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) abcdefghijklmnopqrstuvwxyz all a b c d e f g h i j k l m n o p q r s t u v w x y z] $all $a $b $c $d $e $f $g $h $i $j $k $l $m $n $o $p $q $r $s $t $u $v $w $x $y $z
}
} {1 abcdefghijklmnopqrstuvwxyz a b c d e f g h i j k l m n o p q r s t u v w x y z}
test regexpComp-13.1 {regsub of a very large string} {
# This test is designed to stress the memory subsystem in order
# to catch Bug #933. It only fails if the Tcl memory allocator
# is in use.
set line {BEGIN_TABLE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; END_TABLE}
set filedata [string repeat $line 200]
for {set i 1} {$i<10} {incr i} {
regsub -all "BEGIN_TABLE " $filedata "" newfiledata
}
set x done
} {done}
test regexpComp-14.1 {CompileRegexp: regexp cache} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp $x bbba
}
} 1
test regexpComp-14.2 {CompileRegexp: regexp cache, different flags} {
evalInProc {
regexp .*a b
regexp .*b c
regexp .*c d
regexp .*d e
regexp .*e f
set x .
append x *a
regexp -nocase $x bbba
}
} 1
testConstraint exec [llength [info commands exec]]
test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -constraints {
exec
} -setup {
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
test regexpComp-15.1 {regexp -start} {
catch {unset x}
list [regexp -start -10 {\d} 1abc2de3 x] $x
} {1 1}
test regexpComp-15.2 {regexp -start} {
catch {unset x}
list [regexp -start 2 {\d} 1abc2de3 x] $x
} {1 2}
test regexpComp-15.3 {regexp -start} {
catch {unset x}
list [regexp -start 4 {\d} 1abc2de3 x] $x
} {1 2}
test regexpComp-15.4 {regexp -start} {
catch {unset x}
list [regexp -start 5 {\d} 1abc2de3 x] $x
} {1 3}
test regexpComp-15.5 {regexp -start, over end of string} {
catch {unset x}
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} {0 0}
test regexpComp-15.6 {regexp -start, loss of ^$ behavior} {
list [regexp -start 2 {^$} {}]
} {0}
test regexpComp-16.1 {regsub -start} {
catch {unset x}
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} {4 a1b/2c/3d/4e/5}
test regexpComp-16.2 {regsub -start} {
catch {unset x}
list [regsub -all -start -25 {z} hello {/&} x] $x
} {0 hello}
test regexpComp-16.3 {regsub -start} {
catch {unset x}
list [regsub -all -start 3 {z} hello {/&} x] $x
} {0 hello}
test regexpComp-16.4 {regsub -start, \A behavior} {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} {5 /a/b/c/d/e 3 ab/c/d/e}
test regexpComp-17.1 {regexp -inline} {
regexp -inline b ababa
} {b}
test regexpComp-17.2 {regexp -inline} {
regexp -inline (b) ababa
} {b b}
test regexpComp-17.3 {regexp -inline -indices} {
regexp -inline -indices (b) ababa
} {{1 1} {1 1}}
test regexpComp-17.4 {regexp -inline} {
regexp -inline {\w(\d+)\w} " hello 23 there456def "
} {e456d 456}
test regexpComp-17.5 {regexp -inline no matches} {
regexp -inline {\w(\d+)\w} ""
} {}
test regexpComp-17.6 {regexp -inline no matches} {
regexp -inline hello goodbye
} {}
test regexpComp-17.7 {regexp -inline, no matchvars allowed} {
list [catch {regexp -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexpComp-18.1 {regexp -all} {
regexp -all b bbbbb
} {5}
test regexpComp-18.2 {regexp -all} {
regexp -all b abababbabaaaaaaaaaab
} {6}
test regexpComp-18.3 {regexp -all -inline} {
regexp -all -inline b abababbabaaaaaaaaaab
} {b b b b b b}
test regexpComp-18.4 {regexp -all -inline} {
regexp -all -inline {\w(\w)} abcdefg
} {ab b cd d ef f}
test regexpComp-18.5 {regexp -all -inline} {
regexp -all -inline {\w(\w)$} abcdefg
} {fg g}
test regexpComp-18.6 {regexp -all -inline} {
regexp -all -inline {\d+} 10:20:30:40
} {10 20 30 40}
test regexpComp-18.7 {regexp -all -inline} {
list [catch {regexp -all -inline b abc match} msg] $msg
} {1 {regexp match variables not allowed when using -inline}}
test regexpComp-18.8 {regexp -all} {
# This should not cause an infinite loop
regexp -all -inline {a*} a
} {a}
test regexpComp-18.9 {regexp -all} {
# Yes, the expected result is {a {}}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; this is past the end of the string, so stop.
regexp -all -inline {a*} ab
} {a {}}
test regexpComp-18.10 {regexp -all} {
# Yes, the expected result is {a {} a}. Here's why:
# Start at index 0; a* matches the "a" there then stops.
# Go to index 1; a* matches the lambda (or {}) there then stops. Recall
# that a* matches zero or more "a"'s; thus it matches the string "b", as
# there are zero or more "a"'s there.
# Go to index 2; a* matches the "a" there then stops.
# Go to index 3; this is past the end of the string, so stop.
regexp -all -inline {a*} aba
} {a {} a}
test regexpComp-18.11 {regexp -all} {
evalInProc {
regexp -all -inline {^a} aaaa
}
} {a}
test regexpComp-18.12 {regexp -all -inline -indices} {
evalInProc {
regexp -all -inline -indices a(b(c)d|e(f)g)h abcdhaefgh
}
} {{0 4} {1 3} {2 2} {-1 -1} {5 9} {6 8} {-1 -1} {7 7}}
test regexpComp-19.1 {regsub null replacement} {
evalInProc {
regsub -all {@} {@hel@lo@} "\0a\0" result
list $result [string length $result]
}
} "\0a\0hel\0a\0lo\0a\0 14"
test regexpComp-20.1 {regsub shared object shimmering} {
evalInProc {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
set b $a
set c abcdefghijklmnopqurstuvwxyz0123456789
regsub $a $c $b d
list $d [string length $d] [string bytelength $d]
}
} [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexpComp-20.2 {regsub shared object shimmering with -about} {
evalInProc {
eval regexp -about abc
}
} {0 {}}
test regexpComp-21.1 {regexp command compiling tests} {
evalInProc {
regexp foo bar
}
} 0
test regexpComp-21.2 {regexp command compiling tests} {
evalInProc {
regexp {^foo$} dogfood
}
} 0
test regexpComp-21.3 {regexp command compiling tests} {
evalInProc {
set a foo
regexp {^foo$} $a
}
} 1
test regexpComp-21.4 {regexp command compiling tests} {
evalInProc {
regexp foo dogfood
}
} 1
test regexpComp-21.5 {regexp command compiling tests} {
evalInProc {
regexp -nocase FOO dogfod
}
} 0
test regexpComp-21.6 {regexp command compiling tests} {
evalInProc {
regexp -n foo dogfoOd
}
} 1
test regexpComp-21.7 {regexp command compiling tests} {
evalInProc {
regexp -no -- FoO dogfood
}
} 1
test regexpComp-21.8 {regexp command compiling tests} {
evalInProc {
regexp -- foo dogfod
}
} 0
test regexpComp-21.9 {regexp command compiling tests} {
evalInProc {
list [catch {regexp -- -nocase foo dogfod} msg] $msg
}
} {0 0}
test regexpComp-21.10 {regexp command compiling tests} {
evalInProc {
list [regsub -all "" foo bar str] $str
}
} {3 barfbarobaro}
test regexpComp-21.11 {regexp command compiling tests} {
evalInProc {
list [regsub -all "" "" bar str] $str
}
} {0 {}}
set i 0
foreach {str exp result} {
|
| ︙ | ︙ | |||
810 811 812 813 814 815 816 |
anything ^.*a$ 0
anything ^.*a.*$ 1
anything ^.*.*$ 1
anything ^.*..*$ 1
anything ^.*b$ 0
anything ^a.*$ 1
} {
| | | 814 815 816 817 818 819 820 821 822 823 824 825 826 827 |
anything ^.*a$ 0
anything ^.*a.*$ 1
anything ^.*.*$ 1
anything ^.*..*$ 1
anything ^.*b$ 0
anything ^a.*$ 1
} {
test regexpComp-22.[incr i] {regexp command compiling tests} \
[subst {evalInProc {set a "$str"; regexp {$exp} \$a}}] $result
}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/registry.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # registry.test -- # # This file contains a collection of tests for the registry command. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # In order for these tests to run, the registry package must be on the # auto_path or the registry package must have been loaded already. # # Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved. # Copyright (c) 1998-1999 by Scriptics Corporation. # | | | | | < < | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
# registry.test --
#
# This file contains a collection of tests for the registry command.
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# In order for these tests to run, the registry package must be on the
# auto_path or the registry package must have been loaded already.
#
# Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# RCS: @(#) $Id: registry.test,v 1.12.2.3 2007/03/17 22:41:05 kennykb Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {$tcl_platform(platform) == "windows"} {
if [catch {
set lib [lindex [glob -directory [file join [pwd] [file dirname \
[info nameofexecutable]]] tclreg*.dll] 0]
load $lib registry
}] {
puts "Unable to find the registry package. Skipping registry tests."
return
}
}
# determine the current locale
testConstraint english [expr {[llength [info commands testlocale]]
&& [string equal [testlocale all ""] "English_United States.1252"]
}]
set hostname [info hostname]
test registry-1.1 {argument parsing for registry command} {pcOnly} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry option ?arg arg ...?"}}
test registry-1.2 {argument parsing for registry command} {pcOnly} {
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\u30b7bar
registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
registry delete HKEY_CLASSES_ROOT\\TclFoobar
set result
} "baz\u30b7bar blat"
test registry-5.1 {GetType} {pcOnly english} {
registry delete HKEY_CLASSES_ROOT\\TclFoobar
list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-5.2 {GetType} {pcOnly english} {
registry set HKEY_CLASSES_ROOT\\TclFoobar
| > > > > > > > > > > > > > > | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
registry set HKEY_CLASSES_ROOT\\TclFoobar\\baz\u30b7bar
registry set HKEY_CLASSES_ROOT\\TclFoobar\\blat
registry set HKEY_CLASSES_ROOT\\TclFoobar\\foo
set result [lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar b*]]
registry delete HKEY_CLASSES_ROOT\\TclFoobar
set result
} "baz\u30b7bar blat"
test registry-4.9 {GetKeyNames: very long key [Bug 1682211]} \
-constraints {pcOnly} \
-setup {
registry set HKEY_CLASSES_ROOT\\TclFoobar\\a
registry set HKEY_CLASSES_ROOT\\TclFoobar\\b[string repeat x 254]
registry set HKEY_CLASSES_ROOT\\TclFoobar\\c
} \
-body {
lsort [registry keys HKEY_CLASSES_ROOT\\TclFoobar]
} \
-cleanup {
registry delete HKEY_CLASSES_ROOT\\TclFoobar
} \
-result [list a b[string repeat x 254] c]
test registry-5.1 {GetType} {pcOnly english} {
registry delete HKEY_CLASSES_ROOT\\TclFoobar
list [catch {registry type HKEY_CLASSES_ROOT\\TclFoobar val1} msg] $msg
} {1 {unable to open key: The system cannot find the file specified.}}
test registry-5.2 {GetType} {pcOnly english} {
registry set HKEY_CLASSES_ROOT\\TclFoobar
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
list [catch {registry b {}} msg] $msg
} {0 {1 0}}
# cleanup
unset hostname
::tcltest::cleanupTests
return
| > > > > > > | 608 609 610 611 612 613 614 615 616 617 618 619 620 |
list [catch {registry b {}} msg] $msg
} {0 {1 0}}
# cleanup
unset hostname
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# tcl-indent-level: 4
# fill-column: 78
# End:
|
Changes to tests/resource.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands covered: resource # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# Commands covered: resource
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: resource.test,v 1.7.24.1 2003/10/06 14:30:06 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test resource-1.1 {resource tests} {macOnly} {
|
| ︙ | ︙ | |||
269 270 271 272 273 274 275 |
testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
set id [resource open rsrc2.file w]
set result [catch {resource delete -id 128 -file $id _bad_type_} mssg]
resource close $id
file delete rsrc2.file
lappend result $mssg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
| | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
testWriteTextResource -rsrc fileRsrcName -rsrcid 128 -file rsrc2.file {Some stuff}
set id [resource open rsrc2.file w]
set result [catch {resource delete -id 128 -file $id _bad_type_} mssg]
resource close $id
file delete rsrc2.file
lappend result $mssg
} {1 {expected Macintosh OS type but got "_bad_type_"}}
test resource-8.5.1 {resource delete tests} {macOnly} {
catch {file delete rsrc2.file}
set id [resource open rsrc2.file w]
set result [catch {resource delete -id 128 -file $id TEXT} mssg]
resource close $id
file delete rsrc2.file
lappend result $mssg
} {1 {resource not found}}
|
| ︙ | ︙ |
Changes to tests/result.test.
| ︙ | ︙ | |||
61 62 63 64 65 66 67 |
test result-3.1 {Tcl_DiscardInterpResult} {testsaveresult} {
list [catch {testsaveresult append {cd _foobar} 1} msg] $msg
} {1 {couldn't change working directory to "_foobar": no such file or directory}}
test result-3.2 {Tcl_DiscardInterpResult} {testsaveresult} {
testsaveresult free {set x 42} 1
} {42}
| > > > | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
test result-3.1 {Tcl_DiscardInterpResult} {testsaveresult} {
list [catch {testsaveresult append {cd _foobar} 1} msg] $msg
} {1 {couldn't change working directory to "_foobar": no such file or directory}}
test result-3.2 {Tcl_DiscardInterpResult} {testsaveresult} {
testsaveresult free {set x 42} 1
} {42}
::tcltest::testConstraint testsetobjerrorcode \
[expr {[info commands testsetobjerrorcode] != {}}]
test result-4.1 {Tcl_SetObjErrorCode - one arg} {testsetobjerrorcode} {
catch {testsetobjerrorcode 1}
list [set errorCode]
} {1}
test result-4.2 {Tcl_SetObjErrorCode - two args} {testsetobjerrorcode} {
catch {testsetobjerrorcode 1 2}
list [set errorCode]
} {{1 2}}
test result-4.3 {Tcl_SetObjErrorCode - three args} {testsetobjerrorcode} {
catch {testsetobjerrorcode 1 2 3}
list [set errorCode]
} {{1 2 3}}
test result-4.4 {Tcl_SetObjErrorCode - four args} {testsetobjerrorcode} {
catch {testsetobjerrorcode 1 2 3 4}
list [set errorCode]
} {{1 2 3 4}}
test result-4.5 {Tcl_SetObjErrorCode - five args} {testsetobjerrorcode} {
catch {testsetobjerrorcode 1 2 3 4 5}
list [set errorCode]
} {{1 2 3 4 5}}
::tcltest::testConstraint testseterrorcode \
[expr {[info commands testseterrorcode] != {}}]
test result-5.1 {Tcl_SetErrorCode - one arg} testseterrorcode {
catch {testseterrorcode 1}
set errorCode
} 1
test result-5.2 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode {
catch {testseterrorcode {a b}}
set errorCode
} {{a b}}
test result-5.3 {Tcl_SetErrorCode - one arg, list quoting} testseterrorcode {
catch {testseterrorcode \{}
llength $errorCode
} 1
test result-5.4 {Tcl_SetErrorCode - two args, list quoting} testseterrorcode {
catch {testseterrorcode {a b} c}
set errorCode
} {{a b} c}
test result-6.2 {Bug 1649062} -setup {
proc foo {} {
if {[catch {
return -code error -errorinfo custom -errorcode CUSTOM foo
} err]} {
return [list $err $::errorCode $::errorInfo]
}
}
set ::errorInfo {}
set ::errorCode {}
} -body {
foo
} -cleanup {
rename foo {}
} -result {foo {} {}}
# cleanup
::tcltest::cleanupTests
return
|
| ︙ | ︙ |
Changes to tests/safe.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # safe.test -- # # This file contains a collection of tests for safe Tcl, packages loading, # and using safe interpreters. Sourcing this file into tcl runs the tests # and generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
# safe.test --
#
# This file contains a collection of tests for safe Tcl, packages loading,
# and using safe interpreters. Sourcing this file into tcl runs the tests
# and generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: safe.test,v 1.13.2.3 2006/11/28 22:20:03 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
foreach i [interp slaves] {
interp delete $i
}
set saveAutoPath $::auto_path
set ::auto_path [info library]
# Force actual loading of the safe package
# because we use un exported (and thus un-autoindexed) APIs
# in this test result arguments:
catch {safe::interpConfigure}
proc equiv {x} {return $x}
|
| ︙ | ︙ | |||
179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
if {$tcl_platform(platform) == "windows" && \
[lsearch $r "debug"] != -1} {
set r [lreplace $r 1 1]
}
set threaded [lsearch $r "threaded"]
if {$threaded != -1} {
set r [lreplace $r $threaded $threaded]
}
set r
} {byteOrder platform wordSize}
# more test should be added to check that hostname, nameofexecutable,
# aren't leaking infos, but they still do...
| > > > > > > > > | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
if {$tcl_platform(platform) == "windows" && \
[lsearch $r "debug"] != -1} {
set r [lreplace $r 1 1]
}
set threaded [lsearch $r "threaded"]
if {$threaded != -1} {
set r [lreplace $r $threaded $threaded]
}
set tip [lsearch $r "tip,268"]
if {$tip != -1} {
set r [lreplace $r $tip $tip]
}
set tip [lsearch $r "tip,280"]
if {$tip != -1} {
set r [lreplace $r $tip $tip]
}
set r
} {byteOrder platform wordSize}
# more test should be added to check that hostname, nameofexecutable,
# aren't leaking infos, but they still do...
|
| ︙ | ︙ | |||
515 516 517 518 519 520 521 522 523 524 |
list \
[catch {interp eval $i encoding convertto} msg] \
$msg \
[safe::interpDelete $i];
} {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}}
# cleanup
::tcltest::cleanupTests
return
| > | 526 527 528 529 530 531 532 533 534 535 536 |
list \
[catch {interp eval $i encoding convertto} msg] \
$msg \
[safe::interpDelete $i];
} {1 {wrong # args: should be "encoding convertto ?encoding? data"} {}}
set ::auto_path $saveAutoPath
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/scan.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: scan # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1994 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: scan
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1994 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: scan.test,v 1.14.2.1 2004/08/19 21:12:04 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::testConstraint 64bitInts [expr {0x80000000 > 0}]
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
# input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} {nonPortable} {
set a {}; set b {};
list [scan "4294967280 4294967280" "%u %d" a b] $a \
[expr {$b == -16 || $b == 0x7fffffff}]
} {2 4294967280 1}
| < > > > > | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 |
# input (-16) some return MAX_INT.
#
test scan-5.11 {integer scanning} {nonPortable} {
set a {}; set b {};
list [scan "4294967280 4294967280" "%u %d" a b] $a \
[expr {$b == -16 || $b == 0x7fffffff}]
} {2 4294967280 1}
test scan-5.12 {integer scanning} {64bitInts} {
set a {}; set b {}; set c {}
list [scan "7810179016327718216,6c63546f6c6c6548,661432506755433062510" \
%ld,%lx,%lo a b c] $a $b $c
} {3 7810179016327718216 7810179016327718216 7810179016327718216}
test scan-5.13 {integer scanning and overflow} {
# This test used to fail on some 64-bit systems. [Bug 1011860]
scan {300000000 3000000000 30000000000} {%ld %ld %ld}
} {300000000 3000000000 30000000000}
test scan-6.1 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
} {3 2.1 -300000000.0 0.99962 {}}
test scan-6.2 {floating-point scanning} {
set a {}; set b {}; set c {}; set d {}
|
| ︙ | ︙ |
Changes to tests/set-old.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: set-old.test,v 1.16.2.1 2003/03/27 21:46:32 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc ignore args {}
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 |
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.22 {array command, names option} {
catch {unset a}
set a(22) 3
list [catch {array names a 4 5} msg] $msg
} {1 {bad option "4": must be -exact, -glob, or -regexp}}
| | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > | < < < < < < < | | | | | | | | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 |
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.22 {array command, names option} {
catch {unset a}
set a(22) 3
list [catch {array names a 4 5} msg] $msg
} {1 {bad option "4": must be -exact, -glob, or -regexp}}
test set-old-8.23 {array command, names option} {
catch {unset a}
array names a
} {}
test set-old-8.24 {array command, names option} {
catch {unset a}
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
list [catch {lsort [array names a]} msg] $msg
} {0 {22 Textual_name {name with spaces}}}
test set-old-8.25 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
trace var a(xxx) w ignore
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33}}
test set-old-8.26 {array command, names option} {
catch {unset a}
set a(22) 3; set a(33) 44;
trace var a(xxx) w ignore
set a(xxx) value
list [catch {lsort [array names a]} msg] $msg
} {0 {22 33 xxx}}
test set-old-8.27 {array command, names option} {
catch {unset a}
set a(axy) 3
set a(bxy) 44
set a(no) yes
set a(xxx) value
list [lsort [array names a *xy]] [lsort [array names a]]
} {{axy bxy} {axy bxy no xxx}}
test set-old-8.28 {array command, names option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array names a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.29 {array command, nextelement option} {
list [catch {array nextelement a} msg] $msg
} {1 {wrong # args: should be "array nextelement arrayName searchId"}}
test set-old-8.30 {array command, nextelement option} {
catch {unset a}
list [catch {array nextelement a b} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.31 {array command, nextelement option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array nextelement a b]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.32 {array command, set option} {
list [catch {array set a} msg] $msg
} {1 {wrong # args: should be "array set arrayName list"}}
test set-old-8.33 {array command, set option} {
list [catch {array set a 1 2} msg] $msg
} {1 {wrong # args: should be "array set arrayName list"}}
test set-old-8.34 {array command, set option} {
list [catch {array set a "a \{ c"} msg] $msg
} {1 {unmatched open brace in list}}
test set-old-8.35 {array command, set option} {
catch {unset a}
set a 44
list [catch {array set a {a b c d}} msg] $msg
} {1 {can't set "a(a)": variable isn't array}}
test set-old-8.36 {array command, set option} {
catch {unset a}
set a(xx) yy
array set a {b c d e}
lsort [array get a]
} {b c d e xx yy}
test set-old-8.37 {array command, set option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array set a {x 0}]
}
set a(x)
}
list [catch {foo 1} msg] $msg
} {0 {}}
test set-old-8.38 {array command, set option} {
catch {unset aVaRnAmE}
array set aVaRnAmE {}
list [info exists aVaRnAmE] [catch {set aVaRnAmE} msg] $msg
} {1 1 {can't read "aVaRnAmE": variable is array}}
test set-old-8.38.1 {array command, set scalar} {
catch {unset aVaRnAmE}
set aVaRnAmE 1
list [catch {array set aVaRnAmE {}} msg] $msg
} {1 {can't array set "aVaRnAmE": variable isn't array}}
test set-old-8.38.2 {array command, set alias} {
catch {unset aVaRnAmE}
upvar 0 aVaRnAmE anAliAs
array set anAliAs {}
list [array exists aVaRnAmE] [catch {set anAliAs} msg] $msg
} {1 1 {can't read "anAliAs": variable is array}}
test set-old-8.38.3 {array command, set element alias} {
catch {unset aVaRnAmE}
list [catch {upvar 0 aVaRnAmE(elem) elemAliAs}] \
[catch {array set elemAliAs {}} msg] $msg
} {0 1 {can't array set "elemAliAs": variable isn't array}}
test set-old-8.38.4 {array command, empty set with populated array} {
catch {unset aVaRnAmE}
array set aVaRnAmE [list e1 v1 e2 v2]
array set aVaRnAmE {}
array set aVaRnAmE [list e3 v3]
list [lsort [array names aVaRnAmE]] [catch {set aVaRnAmE(e2)} msg] $msg
} {{e1 e2 e3} 0 v2}
test set-old-8.38.5 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var {}} msg] $msg
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.38.6 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var {a b}} msg] $msg
} {1 {can't set "bogusnamespace::var": parent namespace doesn't exist}}
test set-old-8.38.7 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var(0) {a b}} msg] $msg
} {1 {can't set "bogusnamespace::var(0)": variable isn't array}}
test set-old-8.39 {array command, size option} {
catch {unset a}
array size a
} {0}
test set-old-8.40 {array command, size option} {
list [catch {array size a 4} msg] $msg
} {1 {wrong # args: should be "array size arrayName"}}
test set-old-8.41 {array command, size option} {
catch {unset a}
array size a
} {0}
test set-old-8.42 {array command, size option} {
catch {unset a}
set a(22) 3; set a(Textual_name) 44; set "a(name with spaces)" xxx
list [catch {array size a} msg] $msg
} {0 3}
test set-old-8.43 {array command, size option} {
catch {unset a}
set a(22) 3; set a(xx) 44; set a(y) xxx
unset a(22) a(y) a(xx)
list [catch {array size a} msg] $msg
} {0 0}
test set-old-8.44 {array command, size option} {
catch {unset a}
set a(22) 3;
trace var a(33) rwu ignore
list [catch {array size a} msg] $msg
} {0 1}
test set-old-8.45 {array command, size option, array doesn't exist yet but has compiler-allocated procedure slot} {
proc foo {x} {
if {$x==1} {
return [array size a]
}
set a(x) 123
}
list [catch {foo 1} msg] $msg
} {0 0}
test set-old-8.46 {array command, startsearch option} {
list [catch {array startsearch a b} msg] $msg
} {1 {wrong # args: should be "array startsearch arrayName"}}
test set-old-8.47 {array command, startsearch option} {
catch {unset a}
list [catch {array startsearch a} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.48 {array command, startsearch option, array doesn't exist yet but has compiler-allocated procedure slot} {
catch {rename p ""}
proc p {x} {
if {$x==1} {
return [array startsearch a]
}
set a(x) 123
}
list [catch {p 1} msg] $msg
} {1 {"a" isn't an array}}
test set-old-8.49 {array command, statistics option} {
catch {unset a}
set a(abc) 1
set a(def) 2
set a(ghi) 3
set a(jkl) 4
set a(mno) 5
set a(pqr) 6
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 | number of buckets with 5 entries: 0 number of buckets with 6 entries: 0 number of buckets with 7 entries: 0 number of buckets with 8 entries: 0 number of buckets with 9 entries: 0 number of buckets with 10 or more entries: 0 average search distance for entry: 1.7" | | | | | | | | | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
number of buckets with 5 entries: 0
number of buckets with 6 entries: 0
number of buckets with 7 entries: 0
number of buckets with 8 entries: 0
number of buckets with 9 entries: 0
number of buckets with 10 or more entries: 0
average search distance for entry: 1.7"
test set-old-8.50 {array command, array names -exact on glob pattern} {
catch {unset a}
set a(1*2) 1
list [catch {array names a -exact 1*2} msg] $msg
} {0 1*2}
test set-old-8.51 {array command, array names -glob on glob pattern} {
catch {unset a}
set a(1*2) 1
set a(12) 1
set a(11) 1
list [catch {lsort [array names a -glob 1*2]} msg] $msg
} {0 {1*2 12}}
test set-old-8.52 {array command, array names -regexp on regexp pattern} {
catch {unset a}
set a(1*2) 1
set a(12) 1
set a(11) 1
list [catch {lsort [array names a -regexp ^1]} msg] $msg
} {0 {1*2 11 12}}
test set-old-8.53 {array command, array names -regexp} {
catch {unset a}
set a(-glob) 1
set a(-regexp) 1
set a(-exact) 1
list [catch {array names a -regexp} msg] $msg
} {0 -regexp}
test set-old-8.54 {array command, array names -exact} {
catch {unset a}
set a(-glob) 1
set a(-regexp) 1
set a(-exact) 1
list [catch {array names a -exact} msg] $msg
} {0 -exact}
test set-old-8.55 {array command, array names -glob} {
catch {unset a}
set a(-glob) 1
set a(-regexp) 1
set a(-exact) 1
list [catch {array names a -glob} msg] $msg
} {0 -glob}
test set-old-8.56 {array command, array statistics on a non-array} {
catch {unset a}
list [catch {array statistics a} msg] $msg
} [list 1 "\"a\" isn't an array"]
test set-old-9.1 {ids for array enumeration} {
catch {unset a}
set a(a) 1
|
| ︙ | ︙ |
Changes to tests/socket.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # Commands tested in this file: socket. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | # Commands tested in this file: socket. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: socket.test,v 1.26.2.6 2006/03/16 00:35:59 andreas_kupries Exp $ # Running socket tests with a remote server: # ------------------------------------------ # # Some tests in socket.test depend on the existence of a remote server to # which they connect. The remote server must be an instance of tcltest and it # must run the script found in the file "remote.tcl" in this directory. You |
| ︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 |
list [catch {socket -server callback 2520 --} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.12 {arg parsing for socket command} {socket} {
list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}
set path(script) [makeFile {} script]
test socket-2.1 {tcp connection} {socket stdio} {
| > > > > > > | | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
list [catch {socket -server callback 2520 --} msg] $msg
} {1 {wrong # args: should be either:
socket ?-myaddr addr? ?-myport myport? ?-async? host port
socket -server command ?-myaddr addr? port}}
test socket-1.12 {arg parsing for socket command} {socket} {
list [catch {socket foo badport} msg] $msg
} {1 {expected integer but got "badport"}}
test socket-1.13 {arg parsing for socket command} {socket} {
list [catch {socket -async -server} msg] $msg
} {1 {cannot set -async option for server sockets}}
test socket-1.14 {arg parsing for socket command} {socket} {
list [catch {socket -server foo -async} msg] $msg
} {1 {cannot set -async option for server sockets}}
set path(script) [makeFile {} script]
test socket-2.1 {tcp connection} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timed_out"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
set x done
|
| ︙ | ︙ | |||
280 281 282 283 284 285 286 |
if [info exists port] {
incr port
} else {
set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {socket stdio} {
| | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
if [info exists port] {
incr port
} else {
set port [expr 2048 + [pid]%1024]
}
test socket-2.2 {tcp connection with client port specified} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file] $port"
|
| ︙ | ︙ | |||
316 317 318 319 320 321 322 |
lappend x [gets $f]
close $sock
}
close $f
set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
| | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
lappend x [gets $f]
close $sock
}
close $f
set x
} [list ready "hello $port"]
test socket-2.3 {tcp connection with client interface specified} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 2000 "set x done"]
set f [socket -server accept 2830]
proc accept {file addr port} {
global x
puts "[gets $file] $addr"
|
| ︙ | ︙ | |||
347 348 349 350 351 352 353 |
lappend x [gets $f]
close $sock
}
close $f
set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
| | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 |
lappend x [gets $f]
close $sock
}
close $f
set x
} {ready {hello 127.0.0.1}}
test socket-2.4 {tcp connection with server interface specified} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 2000 "set x done"]
set f [socket -server accept -myaddr 127.0.0.1 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 |
lappend x [gets $f]
close $sock
}
close $f
set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
| | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
lappend x [gets $f]
close $sock
}
close $f
set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
set status broken
}
close $sock
}
set status
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
| | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
set status broken
}
close $sock
}
set status
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 10000 "set x timeout"]
set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -translation lf -buffering line
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
after 1000
set x [gets $s]
close $s
set y [gets $f]
close $f
list $x $y
} {{hello abcdefghijklmnop} done}
| > | | | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
after 1000
set x [gets $s]
close $s
set y [gets $f]
close $f
list $x $y
} {{hello abcdefghijklmnop} done}
removeFile script
test socket-2.8 {echo server, loop 50 times, single connection} -constraints {socket stdio} -setup {
set path(script) [makeFile {
set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
proc echo {s} {
global i
|
| ︙ | ︙ | |||
490 491 492 493 494 495 496 | puts ready puts [lindex [fconfigure $f -sockname] 2] set timer [after 20000 "set x done"] vwait x after cancel $timer close $f puts "done $i" | | > > > | > | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 |
puts ready
puts [lindex [fconfigure $f -sockname] 2]
set timer [after 20000 "set x done"]
vwait x
after cancel $timer
close $f
puts "done $i"
} script]
} -body {
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
gets $f listen
set s [socket 127.0.0.1 $listen]
fconfigure $s -buffering line
catch {
for {set x 0} {$x < 50} {incr x} {
puts $s "hello abcdefghijklmnop"
gets $s
}
}
close $s
catch {set x [gets $f]}
close $f
set x
} -cleanup {
removeFile script
} -result {done 50}
set path(script) [makeFile {} script]
test socket-2.9 {socket conflict} {socket stdio} {
set s [socket -server accept 0]
file delete $path(script)
set f [open $path(script) w]
puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
after 100
set x [list [catch {close $f} msg]]
|
| ︙ | ︙ | |||
575 576 577 578 579 580 581 |
close $s
close $sock
set result
} {a:one b: c:two}
test socket-3.1 {socket conflict} {socket stdio} {
| | | | 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
close $s
close $sock
set result
} {a:one b: c:two}
test socket-3.1 {socket conflict} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set f [socket -server accept 0]
puts ready
puts [lindex [fconfigure $f -sockname] 2]
gets stdin
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r+]
gets $f
gets $f listen
set x [list [catch {socket -server accept $listen} msg] \
$msg]
puts $f bye
close $f
set x
} {1 {couldn't open socket: address already in use}}
test socket-3.2 {server with several clients} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set t1 [after 30000 "set x timed_out"]
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
set counter 0
set s [socket -server accept 0]
|
| ︙ | ︙ | |||
655 656 657 658 659 660 661 |
close $s3
lappend x [gets $f]
close $f
set x
} {ready done}
test socket-4.1 {server with several clients} {socket stdio} {
| | | 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
close $s3
lappend x [gets $f]
close $f
set x
} {ready done}
test socket-4.1 {server with several clients} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set port [gets stdin]
set s [socket 127.0.0.1 $port]
fconfigure $s -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s hello
|
| ︙ | ︙ | |||
755 756 757 758 759 760 761 |
set x {htons problem, should be disallowed, are you running as SU?}
close $msg
}
set x
} {couldn't open socket: not owner}
test socket-6.1 {accept callback error} {socket stdio} {
| | | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 |
set x {htons problem, should be disallowed, are you running as SU?}
close $msg
}
set x
} {couldn't open socket: not owner}
test socket-6.1 {accept callback error} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
gets stdin port
socket 127.0.0.1 $port
}
close $f
set f [open "|[list [interpreter] $path(script)]" r+]
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 |
after cancel $timer
close $s
rename bgerror {}
set x
} {{divide by zero}}
test socket-7.1 {testing socket specific options} {socket stdio} {
| | | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 |
after cancel $timer
close $s
rename bgerror {}
set x
} {{divide by zero}}
test socket-7.1 {testing socket specific options} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set ss [socket -server accept 0]
proc accept args {
global x
set x done
}
|
| ︙ | ︙ | |||
808 809 810 811 812 813 814 |
close $f
set l ""
lappend l [string compare [lindex $p 0] 127.0.0.1]
lappend l [string compare [lindex $p 2] $listen]
lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {socket stdio} {
| | | 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 |
close $f
set l ""
lappend l [string compare [lindex $p 0] 127.0.0.1]
lappend l [string compare [lindex $p 2] $listen]
lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {socket stdio} {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set ss [socket -server accept 2821]
proc accept args {
global x
set x done
}
|
| ︙ | ︙ | |||
1288 1289 1290 1291 1292 1293 1294 |
}
} else {
incr len [string length $l]
}
}
set c [socket $remoteServerIP 2836]
fileevent $c readable "readlittle $c"
| | | | | 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 |
}
} else {
incr len [string length $l]
}
}
set c [socket $remoteServerIP 2836]
fileevent $c readable "readlittle $c"
set timer [after 40000 "set done timed_out"]
vwait done
after cancel $timer
sendCommand {close $socket10_13_test_server}
list $spurious $len $done
} {0 2690 1}
test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} {
set counter 0
set done 0
proc count_up {s} {
global counter done after_id
set l [gets $s]
|
| ︙ | ︙ | |||
1387 1388 1389 1390 1391 1392 1393 |
set count
} 65566
set path(script1) [makeFile {} script1]
set path(script2) [makeFile {} script2]
test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} {
| | | | | > > < > < < | | | | > > < > | 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 |
set count
} 65566
set path(script1) [makeFile {} script1]
set path(script2) [makeFile {} script2]
test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} {
file delete $path(script1)
file delete $path(script2)
# Script1 is just a 10 second delay. If the server socket
# is inherited, it will be held open for 10 seconds
set f [open $path(script1) w]
puts $f {
after 10000 exit
vwait forever
}
close $f
# Script2 creates the server socket, launches script1,
# waits a second, and exits. The server socket will now
# be closed unless script1 inherited it.
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts -nonewline $f {
set f [socket -server accept 0]
puts [lindex [fconfigure $f -sockname] 2]
proc accept { file addr port } {
close $file
}
exec $tcltest }
puts $f [list $path(script1) &]
puts $f {
close $f
after 1000 exit
vwait forever
}
close $f
# Launch script2 and wait 5 seconds
### exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" r]
gets $p listen
after 5000 { set ok_to_proceed 1 }
vwait ok_to_proceed
# If we can still connect to the server, the socket got inherited.
if {[catch {socket 127.0.0.1 $listen} msg]} {
set x {server socket was not inherited}
} else {
close $msg
set x {server socket was inherited}
}
close $p
set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
file delete $path(script1)
file delete $path(script2)
# Script1 is just a 20 second delay. If the server socket
# is inherited, it will be held open for 10 seconds
set f [open $path(script1) w]
puts $f {
after 20000 exit
vwait forever
}
close $f
# Script2 opens the client socket and writes to it. It then
# launches script1 and exits. If the child process inherited the
# client socket, the socket will still be open.
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts -nonewline $f {
gets stdin port
set f [socket 127.0.0.1 $port]
exec $tcltest }
puts $f [list $path(script1) &]
puts $f {
puts $f testing
flush $f
after 1000 exit
vwait forever
}
close $f
# Create the server socket
set server [socket -server accept 0]
proc accept { file host port } {
# When the client connects, establish the read handler
|
| ︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 |
set p [open "|[list [interpreter] $path(script2)]" w]
puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
vwait x
if {!$failed} {
vwait failed
}
| < < | | | | > > | > > > > < > | 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 |
set p [open "|[list [interpreter] $path(script2)]" w]
puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
vwait x
if {!$failed} {
vwait failed
}
close $p
set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
file delete $path(script1)
file delete $path(script2)
set f [open $path(script1) w]
puts $f {
after 10000 exit
vwait forever
}
close $f
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts -nonewline $f {
set server [socket -server accept 0]
puts stdout [lindex [fconfigure $server -sockname] 2]
proc accept { file host port } }
puts $f \{
puts -nonewline $f {
global tcltest
puts $file {test data on socket}
exec $tcltest }
puts $f [list $path(script1) &]
puts $f {
after 1000 exit
}
puts $f \}
puts $f {
vwait forever
}
close $f
# Launch the script2 process and connect to it. See how long
# the socket stays open
## exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" r]
|
| ︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 |
catch { close $file }
}
return
}
vwait x
| < < | < | | 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 |
catch { close $file }
}
return
}
vwait x
close $p
set x
} {accepted socket was not inherited}
test socket-13.1 {Testing use of shared socket between two threads} \
-constraints {socket testthread} -setup {
threadReap
set path(script) [makeFile {
set f [socket -server accept 0]
set listen [lindex [fconfigure $f -sockname] 2]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
}
proc echo {s} {
|
| ︙ | ︙ | |||
1638 1639 1640 1641 1642 1643 1644 | } set i 0 vwait x close $f # thread cleans itself up. testthread exit | | | > | | > | < > > | 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 |
}
set i 0
vwait x
close $f
# thread cleans itself up.
testthread exit
} script]
} -body {
# create a thread
set serverthread [testthread create [list source $path(script) ] ]
update
set port [testthread send $serverthread {set listen}]
update
after 1000
set s [socket 127.0.0.1 $port]
fconfigure $s -buffering line
catch {
puts $s "hello"
gets $s result
}
close $s
update
after 2000
lappend result [threadReap]
} -cleanup {
removeFile script
} -result {hello 1}
removeFile script1
removeFile script2
# cleanup
if {[string match sock* $commandSocket] == 1} {
puts $commandSocket exit
flush $commandSocket
}
catch {close $commandSocket}
catch {close $remoteProcChan}
::tcltest::cleanupTests
flush stdout
return
|
Changes to tests/source.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: source # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | > | < | | > > > > > > > > | | | | > > > | > | | > > > | > | < | | < | > > | > > > > > > > > > > > > > | | | > | > > | > | | | > | | > | > > > | | | > | > > > | | > > > | > | > > | | | > > > | > | | | > | > > | > | | | > | > > | > | | | > | > > | > | | | > | > > | > | | | > > | | | > | | | > | | | > | | | > > > > > | > > > | | > | | > | > > > | > | > > > > > | > < > > | > | > > | > > > | > | < > > | > | > > > > > | > > | < > > | > | | > | > < > | > > > > > > > | > > > > < > > > | | > > < | > > | < > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
# Commands covered: source
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
# Contributions from Don Porter, NIST, 2003. (not subject to US copyright)
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: source.test,v 1.8.2.2 2004/02/25 23:38:17 dgp Exp $
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
namespace eval ::tcl::test::source {
namespace import ::tcltest::test
namespace import ::tcltest::testConstraint
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::customMatch
test source-1.1 {source command} -setup {
set x "old x value"
set y "old y value"
set z "old z value"
set sourcefile [makeFile {
set x 22
set y 33
set z 44
} source.file]
} -body {
source $sourcefile
list $x $y $z
} -cleanup {
removeFile source.file
} -result {22 33 44}
test source-1.2 {source command} -setup {
set sourcefile [makeFile {list result} source.file]
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -result result
test source-1.3 {source command} -setup {
set sourcefile [makeFile {} source.file]
set fd [open $sourcefile w]
fconfigure $fd -translation lf
puts $fd "list a b c \\"
puts $fd "d e f"
close $fd
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -result {a b c d e f}
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
return 0
}
foreach e $expected a $actual {
if {![string match $e $a]} {
return 0
}
}
return 1
}
customMatch listGlob [namespace which ListGlobMatch]
test source-2.3 {source error conditions} -setup {
set sourcefile [makeFile {
set x 146
error "error in sourced file"
set y $x
} source.file]
} -body {
list [catch {source $sourcefile} msg] $msg $::errorInfo
} -cleanup {
removeFile source.file
} -match listGlob -result [list 1 {error in sourced file} \
{error in sourced file
while executing
"error "error in sourced file""
(file "*source.file" line 3)
invoked from within
"source $sourcefile"}]
test source-2.4 {source error conditions} -setup {
set sourcefile [makeFile {break} source.file]
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -returnCodes break
test source-2.5 {source error conditions} -setup {
set sourcefile [makeFile {continue} source.file]
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -returnCodes continue
test source-2.6 {source error conditions} -setup {
set sourcefile [makeFile {} _non_existent_]
removeFile _non_existent_
} -body {
list [catch {source $sourcefile} msg] $msg $::errorCode
} -match listGlob -result [list 1 \
{couldn't read file "*_non_existent_": no such file or directory} \
{POSIX ENOENT {no such file or directory}}]
test source-3.1 {return in middle of source file} -setup {
set sourcefile [makeFile {
set x new-x
return allDone
set y new-y
} source.file]
} -body {
set x old-x
set y old-y
set z [source $sourcefile]
list $x $y $z
} -cleanup {
removeFile source.file
} -result {new-x old-y allDone}
test source-3.2 {return with special code etc.} -setup {
set sourcefile [makeFile {
set x new-x
return -code break "Silly result"
set y new-y
} source.file]
} -body {
source $sourcefile
} -cleanup {
removeFile source.file
} -returnCodes break -result {Silly result}
test source-3.3 {return with special code etc.} -setup {
set sourcefile [makeFile {
set x new-x
return -code error "Simulated error"
set y new-y
} source.file]
} -body {
list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
removeFile source.file
} -result {1 {Simulated error} {Simulated error
while executing
"source $sourcefile"} NONE}
test source-3.4 {return with special code etc.} -setup {
set sourcefile [makeFile {
set x new-x
return -code error -errorinfo "Simulated errorInfo stuff"
set y new-y
} source.file]
} -body {
list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
removeFile source.file
} -result {1 {} {Simulated errorInfo stuff
invoked from within
"source $sourcefile"} NONE}
test source-3.5 {return with special code etc.} -setup {
set sourcefile [makeFile {
set x new-x
return -code error -errorinfo "Simulated errorInfo stuff" \
-errorcode {a b c}
set y new-y
} source.file]
} -body {
list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode
} -cleanup {
removeFile source.file
} -result {1 {} {Simulated errorInfo stuff
invoked from within
"source $sourcefile"} {a b c}}
# Test for the Macintosh specfic features of the source command
test source-4.1 {source error conditions} -constraints macOnly -body {
source -rsrc _no_exist_
} -result {The resource "_no_exist_" could not be loaded from application.} \
-returnCodes error
test source-4.2 {source error conditions} -constraints macOnly -body {
source -rsrcid bad_id
} -returnCodes error -result {expected integer but got "bad_id"}
test source-4.3 {source error conditions} -constraints macOnly -body {
source -rsrc rsrcName fileName extra
} -returnCodes error -result {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?" or "source -encoding name fileName"}
test source-4.4 {source error conditions} -constraints macOnly -body {
source non_switch rsrcName
} -returnCodes error -result {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?" or "source -encoding name fileName"}
test source-4.5 {source error conditions} -constraints macOnly -body {
source -bad_switch argument
} -returnCodes error -result {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?" or "source -encoding name fileName"}
testConstraint testWriteTextResource \
[llength [info commands testWriteTextResource]]
test source-5.1 {source resource files} -constraints macOnly -setup {
set sourcefile [makeFile {} bad_file]
removeFile bad_file
} -body {
source -rsrc rsrcName $sourcefile
} -returnCodes error -match glob -result {Error finding the file: "*bad_file".}
test source-5.2 {source resource files} -constraints macOnly -setup {
set sourcefile [makeFile {return} source.file]
} -body {
source -rsrc rsrcName $sourcefile
} -cleanup {
removeFile source.file
} -returnCodes error -match glob \
-result {Error reading the file: "*source.file".}
test source-5.3 {source resource files} -constraints {
macOnly testWriteTextResource
} -setup {
set msg2 unset
set rsrcFile [makeFile {} rsrc.file]
removeFile rsrc.file
testWriteTextResource -rsrc rsrcName -file $rsrc.file {set msg2 ok; return}
} -body {
set result [catch {source -rsrc rsrcName rsrc.file} msg]
list $msg2 $result $msg
} -cleanup {
removeFile rsrc.file
} -result [list ok 0 {}]
test source-5.4 {source resource files} -constraints {
macOnly testWriteTextResource
} -setup {
set msg2 unset
set rsrsFile [makeFile {} rsrc.file]
removeFile rsrc.file
testWriteTextResource -rsrc fileRsrcName \
-file $rsrcFile {set msg2 ok; return}
} -body {
source -rsrc fileRsrcName $rsrcFile
set result [catch {source -rsrc fileRsrcName} msg]
list $msg2 $result $msg
} -cleanup {
removeFile rsrc.file
} -result [list ok 1 {The resource "fileRsrcName" could not be loaded from application.}]
test source-5.5 {source resource files} -constraints {
macOnly testWriteTextResource
} -setup {
set msg2 unset
set rsrcFile [makeFile {} rsrc.file]
removeFile rsrc.file
testWriteTextResource -rsrcid 200 \
-file $rsrcFile {set msg2 hello; set msg3 bye}
} -body {
set result [catch {source -rsrcid 200 $rsrcFile} msg]
list $msg2 $result $msg
} -cleanup {
removeFile rsrc.file
} -result [list hello 0 bye]
test source-5.6 {source resource files} -constraints {
macOnly testWriteTextResource
} -setup {
set msg2 unset
set rsrcFile [makeFile {} rsrc.file]
removeFile rsrc.file
testWriteTextResource -rsrcid 200 \
-file $rsrcFile {set msg2 hello; error bad; set msg3 bye}
} -body {
set result [catch {source -rsrcid 200 rsrc.file} msg]
list $msg2 $result $msg
} -cleanup {
removeFile rsrc.file
} -result [list hello 1 bad]
test source-6.1 {source is binary ok} -setup {
# Note [makeFile] writes in the system encoding.
# [source] defaults to reading in the system encoding.
set sourcefile [makeFile [list set x "a b\0c"] source.file]
} -body {
set x {}
source $sourcefile
string length $x
} -cleanup {
removeFile source.file
} -result 5
test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} -setup {
set sourcefile [makeFile "set x ab\32c" source.file]
} -body {
set x {}
source $sourcefile
string length $x
} -cleanup {
removeFile source.file
} -result 2
cleanupTests
}
namespace delete ::tcl::test::source
return
|
Changes to tests/stack.test.
1 2 3 4 5 6 7 8 9 10 11 | # Tests that the stack size is big enough for the application. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# Tests that the stack size is big enough for the application.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: stack.test,v 1.15.2.1 2004/05/03 18:01:36 kennykb Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Note that a failure in this test results in a crash of the executable.
|
| ︙ | ︙ | |||
51 52 53 54 55 56 57 58 59 60 |
interp create $slave
$slave eval { interp alias {} unknown {} notaknownproc }
set msg [$slave eval { catch {foo} msg ; set msg }]
interp delete $slave
set msg
} {too many nested evaluations (infinite loop?)}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
interp create $slave
$slave eval { interp alias {} unknown {} notaknownproc }
set msg [$slave eval { catch {foo} msg ; set msg }]
interp delete $slave
set msg
} {too many nested evaluations (infinite loop?)}
# Make sure that there is enough stack to run regexp even if we're
# close to the recursion limit. [Bug 947070]
test stack-3.1 {enough room for regexp near recursion limit} \
-constraints { win } \
-setup {
set ::limit [interp recursionlimit {} 10000]
set ::depth 0
proc a { max } {
if { [info level] < $max } {
set ::depth [info level]
a $max
} else {
regexp {^ ?} x
}
}
list [catch { a 10001 }]
incr depth -3
set depth2 $depth
} -body {
list [catch { a $::depth } result] \
$result [expr { $::depth2 - $::depth }]
} -cleanup {
interp recursionlimit {} $::limit
} -result {0 1 1}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/string.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: string.test,v 1.36.2.7 2006/01/23 12:11:15 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
set ::tcltest::testConstraints(testobj) \
[expr {[info commands testobj] != {}}]
set ::tcltest::testConstraints(testindexobj) \
[expr {[info commands testindexobj] != {}}]
test string-1.1 {error conditions} {
list [catch {string gorp a b} msg] $msg
} {1 {bad option "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test string-1.2 {error conditions} {
list [catch {string} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
} -1
test string-4.13 {string first, start index} {
string first \u7266 abc\u7266x end-2
} 3
test string-4.14 {string first, negative start index} {
string first b abc -1
} 1
test string-5.1 {string index} {
list [catch {string index} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2 {string index} {
list [catch {string index a b c} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
| > > > > > > > | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
} -1
test string-4.13 {string first, start index} {
string first \u7266 abc\u7266x end-2
} 3
test string-4.14 {string first, negative start index} {
string first b abc -1
} 1
test string-4.15 {string first, ability to two-byte encoded utf-8 chars} {
# Test for a bug in Tcl 8.3 where test for all-single-byte-encoded
# strings was incorrect, leading to an index returned by [string first]
# which pointed past the end of the string.
set uchar \u057e ;# character with two-byte encoding in utf-8
string first % %#$uchar$uchar#$uchar$uchar#% 3
} 8
test string-5.1 {string index} {
list [catch {string index} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test string-5.2 {string index} {
list [catch {string index a b c} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 594 595 596 597 598 599 600 |
set result ""
set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
foreach num $numbers {
lappend result [string is double -strict $num]
}
set result
} {1 1 0 0 0 1 0 0}
catch {rename largest_int {}}
test string-7.1 {string last, too few args} {
list [catch {string last a} msg] $msg
} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.2 {string last, bad args} {
| > > > > > > > > > > > > > > > > | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
set result ""
set numbers [list 1.0 +1.0 ++1.0 +-1.0 -+1.0 -1.0 --1.0 "- +1.0"]
foreach num $numbers {
lappend result [string is double -strict $num]
}
set result
} {1 1 0 0 0 1 0 0}
test string-6.92 {string is double, 32-bit overflow} {
# Bug 718878
set x 0x100000000
list [string is integer -failindex var $x] $var
} {0 -1}
test string-6.93 {string is double, 32-bit overflow} {
# Bug 718878
set x 0x100000000
append x ""
list [string is integer -failindex var $x] $var
} {0 -1}
test string-6.94 {string is double, 32-bit overflow} {
# Bug 718878
set x 0x100000000
list [string is integer -failindex var [expr {$x}]] $var
} {0 -1}
catch {rename largest_int {}}
test string-7.1 {string last, too few args} {
list [catch {string last a} msg] $msg
} {1 {wrong # args: should be "string last subString string ?startIndex?"}}
test string-7.2 {string last, bad args} {
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
} {a4321CaBa43214321c4321}
test string-10.18 {string map, empty argument} {
string map -nocase {{} abc} foo
} foo
test string-10.19 {string map, empty arguments} {
string map -nocase {{} abc f bar {} def} foo
} baroo
test string-11.1 {string match, too few args} {
list [catch {string match a} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.2 {string match, too many args} {
list [catch {string match a b c d} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 |
} {a4321CaBa43214321c4321}
test string-10.18 {string map, empty argument} {
string map -nocase {{} abc} foo
} foo
test string-10.19 {string map, empty arguments} {
string map -nocase {{} abc f bar {} def} foo
} baroo
test string-10.20 {string map, nasty sharing crash from [Bug 1018562]} {
set a {a b}
string map $a $a
} {b b}
test string-10.21 {string map, ABR checks} {
string map {longstring foob} long
} long
test string-10.22 {string map, ABR checks} {
string map {long foob} long
} foob
test string-10.23 {string map, ABR checks} {
string map {lon foob} long
} foobg
test string-10.24 {string map, ABR checks} {
string map {lon foob} longlo
} foobglo
test string-10.25 {string map, ABR checks} {
string map {lon foob} longlon
} foobgfoob
test string-10.26 {string map, ABR checks} {
string map {longstring foob longstring bar} long
} long
test string-10.27 {string map, ABR checks} {
string map {long foob longstring bar} long
} foob
test string-10.28 {string map, ABR checks} {
string map {lon foob longstring bar} long
} foobg
test string-10.29 {string map, ABR checks} {
string map {lon foob longstring bar} longlo
} foobglo
test string-10.30 {string map, ABR checks} {
string map {lon foob longstring bar} longlon
} foobgfoob
test string-11.1 {string match, too few args} {
list [catch {string match a} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test string-11.2 {string match, too many args} {
list [catch {string match a b c d} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 |
set r1 [string range $b 1 end-1]
set r2 [string range $b 1 6]
string equal $r1 $r2
} 1
test string-12.20 {string range, out of bounds indices} {
string range \u00ff 0 1
} \u00ff
test string-13.1 {string repeat} {
list [catch {string repeat} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.2 {string repeat} {
list [catch {string repeat abc 10 oops} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
| > > > > > > > > > > > > > > > | 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 |
set r1 [string range $b 1 end-1]
set r2 [string range $b 1 6]
string equal $r1 $r2
} 1
test string-12.20 {string range, out of bounds indices} {
string range \u00ff 0 1
} \u00ff
test string-12.21 {string range, regenerates correct reps, bug 1410553} {
set bytes "\x00 \x03 \x41"
set rxBuffer {}
foreach ch $bytes {
append rxBuffer $ch
if {$ch eq "\x03"} {
string length $rxBuffer
}
}
set rxCRC [string range $rxBuffer end-1 end]
binary scan [join $bytes {}] "H*" input_hex
binary scan $rxBuffer "H*" rxBuffer_hex
binary scan $rxCRC "H*" rxCRC_hex
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-13.1 {string repeat} {
list [catch {string repeat} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
test string-13.2 {string repeat} {
list [catch {string repeat abc 10 oops} msg] $msg
} {1 {wrong # args: should be "string repeat string count"}}
|
| ︙ | ︙ | |||
1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 |
} 4
test string-22.12 {string wordstart, unicode} {
string wordstart "ab\uc700\uc700 cdef ghi" 12
} 10
test string-22.13 {string wordstart, unicode} {
string wordstart "\uc700\uc700 abc" 8
} 3
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > | 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 |
} 4
test string-22.12 {string wordstart, unicode} {
string wordstart "ab\uc700\uc700 cdef ghi" 12
} 10
test string-22.13 {string wordstart, unicode} {
string wordstart "\uc700\uc700 abc" 8
} 3
test string-23.0 {string is boolean, Bug 1187123} testindexobj {
set x 5
catch {testindexobj $x foo bar soom}
string is boolean $x
} 0
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/stringComp.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | # # Copyright (c) 2001 by ActiveState Corporation. # Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
#
# Copyright (c) 2001 by ActiveState Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: stringComp.test,v 1.6.2.1 2004/10/28 00:01:12 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Some tests require the testobj command
set ::tcltest::testConstraints(testobj) \
[expr {[info commands testobj] != {}}]
test stringComp-1.1 {error conditions} {
proc foo {} {string gorp a b}
list [catch {foo} msg] $msg
} {1 {bad option "gorp": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstart}}
test stringComp-1.2 {error conditions} {
proc foo {} {string}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string option arg ?arg ...?"}}
test stringComp-1.3 {error condition - undefined method during compile} {
# We don't want this to complain about 'never' because it may never
# be called, or string may get redefined. This must compile OK.
proc foo {str i} {
if {"yes" == "no"} { string never called but complains here }
string index $str $i
}
foo abc 0
} a
test stringComp-2.1 {string compare, too few args} {
proc foo {} {string compare a}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test stringComp-2.2 {string compare, bad args} {
proc foo {} {string compare a b c}
list [catch {foo} msg] $msg
} {1 {bad option "a": must be -nocase or -length}}
test stringComp-2.3 {string compare, bad args} {
list [catch {string compare -length -nocase str1 str2} msg] $msg
} {1 {expected integer but got "-nocase"}}
test stringComp-2.4 {string compare, too many args} {
list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test stringComp-2.5 {string compare with length unspecified} {
list [catch {string compare -length 10 10} msg] $msg
} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}}
test stringComp-2.6 {string compare} {
proc foo {} {string compare abcde abdef}
foo
} -1
test stringComp-2.7 {string compare, shortest method name} {
proc foo {} {string c abcde ABCDE}
foo
} 1
test stringComp-2.8 {string compare} {
proc foo {} {string compare abcde abcde}
foo
} 0
test stringComp-2.9 {string compare with length} {
proc foo {} {string compare -length 2 abcde abxyz}
foo
} 0
test stringComp-2.10 {string compare with special index} {
proc foo {} {string compare -length end-3 abcde abxyz}
list [catch {foo} msg] $msg
} {1 {expected integer but got "end-3"}}
test stringComp-2.11 {string compare, unicode} {
proc foo {} {string compare ab\u7266 ab\u7267}
foo
} -1
test stringComp-2.12 {string compare, high bit} {
# This test will fail if the underlying comparaison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
proc foo {} {string compare "\x80" "@"}
foo
# Nb this tests works also in utf8 space because \x80 is
# translated into a 2 or more bytelength but whose first byte has
# the high bit set.
} 1
test stringComp-2.13 {string compare -nocase} {
proc foo {} {string compare -nocase abcde abdef}
foo
} -1
test stringComp-2.14 {string compare -nocase} {
proc foo {} {string c -nocase abcde ABCDE}
foo
} 0
test stringComp-2.15 {string compare -nocase} {
proc foo {} {string compare -nocase abcde abcde}
foo
} 0
test stringComp-2.16 {string compare -nocase with length} {
proc foo {} {string compare -length 2 -nocase abcde Abxyz}
foo
} 0
test stringComp-2.17 {string compare -nocase with length} {
proc foo {} {string compare -nocase -length 3 abcde Abxyz}
foo
} -1
test stringComp-2.18 {string compare -nocase with length <= 0} {
proc foo {} {string compare -nocase -length -1 abcde AbCdEf}
foo
} -1
test stringComp-2.19 {string compare -nocase with excessive length} {
proc foo {} {string compare -nocase -length 50 AbCdEf abcde}
foo
} 1
test stringComp-2.20 {string compare -len unicode} {
# These are strings that are 6 BYTELENGTH long, but the length
# shouldn't make a different because there are actually 3 CHARS long
proc foo {} {string compare -len 5 \334\334\334 \334\334\374}
foo
} -1
test stringComp-2.21 {string compare -nocase with special index} {
proc foo {} {string compare -nocase -length end-3 Abcde abxyz}
list [catch {foo} msg] $msg
} {1 {expected integer but got "end-3"}}
test stringComp-2.22 {string compare, null strings} {
proc foo {} {string compare "" ""}
foo
} 0
test stringComp-2.23 {string compare, null strings} {
proc foo {} {string compare "" foo}
foo
} -1
test stringComp-2.24 {string compare, null strings} {
proc foo {} {string compare foo ""}
foo
} 1
test stringComp-2.25 {string compare -nocase, null strings} {
proc foo {} {string compare -nocase "" ""}
foo
} 0
test stringComp-2.26 {string compare -nocase, null strings} {
proc foo {} {string compare -nocase "" foo}
foo
} -1
test stringComp-2.27 {string compare -nocase, null strings} {
proc foo {} {string compare -nocase foo ""}
foo
} 1
test stringComp-2.28 {string compare with length, unequal strings} {
proc foo {} {string compare -length 2 abc abde}
foo
} 0
test stringComp-2.29 {string compare with length, unequal strings} {
proc foo {} {string compare -length 2 ab abde}
foo
} 0
test stringComp-2.30 {string compare with NUL character vs. other ASCII} {
# Be careful here, since UTF-8 rep comparison with memcmp() of
# these puts chars in the wrong order
proc foo {} {string compare \x00 \x01}
foo
} -1
test stringComp-2.31 {string compare, high bit} {
proc foo {} {string compare "a\x80" "a@"}
foo
} 1
test stringComp-2.32 {string compare, high bit} {
proc foo {} {string compare "a\x00" "a\x01"}
foo
} -1
test stringComp-2.33 {string compare, high bit} {
proc foo {} {string compare "\x00\x00" "\x00\x01"}
foo
} -1
# only need a few tests on equal, since it uses the same code as
# string compare, but just modifies the return output
test stringComp-3.1 {string equal} {
proc foo {} {string equal abcde abdef}
foo
} 0
test stringComp-3.2 {string equal} {
proc foo {} {string eq abcde ABCDE}
foo
} 0
test stringComp-3.3 {string equal} {
proc foo {} {string equal abcde abcde}
foo
} 1
test stringComp-3.4 {string equal -nocase} {
proc foo {} {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334}
foo
} 1
test stringComp-3.5 {string equal -nocase} {
proc foo {} {string equal -nocase abcde abdef}
foo
} 0
test stringComp-3.6 {string equal -nocase} {
proc foo {} {string eq -nocase abcde ABCDE}
foo
} 1
test stringComp-3.7 {string equal -nocase} {
proc foo {} {string equal -nocase abcde abcde}
foo
} 1
test stringComp-3.8 {string equal with length, unequal strings} {
proc foo {} {string equal -length 2 abc abde}
foo
} 1
test stringComp-4.1 {string first, too few args} {
proc foo {} {string first a}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test stringComp-4.2 {string first, bad args} {
proc foo {} {string first a b c}
list [catch {foo} msg] $msg
} {1 {bad index "c": must be integer or end?-integer?}}
test stringComp-4.3 {string first, too many args} {
proc foo {} {string first a b 5 d}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string first subString string ?startIndex?"}}
test stringComp-4.4 {string first} {
proc foo {} {string first bq abcdefgbcefgbqrs}
foo
} 12
test stringComp-4.5 {string first} {
proc foo {} {string fir bcd abcdefgbcefgbqrs}
foo
} 1
test stringComp-4.6 {string first} {
proc foo {} {string f b abcdefgbcefgbqrs}
foo
} 1
test stringComp-4.7 {string first} {
proc foo {} {string first xxx x123xx345xxx789xxx012}
foo
} 9
test stringComp-4.8 {string first} {
proc foo {} {string first "" x123xx345xxx789xxx012}
foo
} -1
test stringComp-4.9 {string first, unicode} {
proc foo {} {string first x abc\u7266x}
foo
} 4
test stringComp-4.10 {string first, unicode} {
proc foo {} {string first \u7266 abc\u7266x}
foo
} 3
test stringComp-4.11 {string first, start index} {
proc foo {} {string first \u7266 abc\u7266x 3}
foo
} 3
test stringComp-4.12 {string first, start index} {
proc foo {} {string first \u7266 abc\u7266x 4}
foo
} -1
test stringComp-4.13 {string first, start index} {
proc foo {} {string first \u7266 abc\u7266x end-2}
foo
} 3
test stringComp-4.14 {string first, negative start index} {
proc foo {} {string first b abc -1}
foo
} 1
test stringComp-5.1 {string index} {
proc foo {} {string index}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test stringComp-5.2 {string index} {
proc foo {} {string index a b c}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
test stringComp-5.3 {string index} {
proc foo {} {string index abcde 0}
foo
} a
test stringComp-5.4 {string index} {
proc foo {} {string in abcde 4}
foo
} e
test stringComp-5.5 {string index} {
proc foo {} {string index abcde 5}
foo
} {}
test stringComp-5.6 {string index} {
proc foo {} {string index abcde -10}
list [catch {foo} msg] $msg
} {0 {}}
test stringComp-5.7 {string index} {
proc foo {} {string index a xyz}
list [catch {foo} msg] $msg
} {1 {bad index "xyz": must be integer or end?-integer?}}
test stringComp-5.8 {string index} {
proc foo {} {string index abc end}
foo
} c
test stringComp-5.9 {string index} {
proc foo {} {string index abc end-1}
foo
} b
test stringComp-5.10 {string index, unicode} {
proc foo {} {string index abc\u7266d 4}
foo
} d
test stringComp-5.11 {string index, unicode} {
proc foo {} {string index abc\u7266d 3}
foo
} \u7266
test stringComp-5.12 {string index, unicode over char length, under byte length} {
proc foo {} {string index \334\374\334\374 6}
foo
} {}
test stringComp-5.13 {string index, bytearray object} {
proc foo {} {string index [binary format a5 fuz] 0}
foo
} f
test stringComp-5.14 {string index, bytearray object} {
proc foo {} {string index [binary format I* {0x50515253 0x52}] 3}
foo
} S
test stringComp-5.15 {string index, bytearray object} {
proc foo {} {
set b [binary format I* {0x50515253 0x52}]
set i1 [string index $b end-6]
set i2 [string index $b 1]
string compare $i1 $i2
}
foo
} 0
test stringComp-5.16 {string index, bytearray object with string obj shimmering} {
proc foo {} {
set str "0123456789\x00 abcdedfghi"
binary scan $str H* dump
string compare [string index $str 10] \x00
}
foo
} 0
test stringComp-5.17 {string index, bad integer} {
proc foo {} {string index "abc" 08}
list [catch {foo} msg] $msg
} {1 {bad index "08": must be integer or end?-integer? (looks like invalid octal number)}}
test stringComp-5.18 {string index, bad integer} {
proc foo {} {string index "abc" end-00289}
list [catch {foo} msg] $msg
} {1 {bad index "end-00289": must be integer or end?-integer? (looks like invalid octal number)}}
test stringComp-5.19 {string index, bytearray object out of bounds} {
proc foo {} {string index [binary format I* {0x50515253 0x52}] -1}
foo
} {}
test stringComp-5.20 {string index, bytearray object out of bounds} {
proc foo {} {string index [binary format I* {0x50515253 0x52}] 20}
foo
} {}
proc largest_int {} {
# This will give us what the largest valid int on this machine is,
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 |
catch {rename largest_int {}}
## string last
## not yet bc
## string length
## not yet bc
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
catch {rename largest_int {}}
## string last
## not yet bc
## string length
## not yet bc
test stringComp-8.1 {string bytelength} {
proc foo {} {string bytelength}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test stringComp-8.2 {string bytelength} {
proc foo {} {string bytelength a b}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test stringComp-8.3 {string bytelength} {
proc foo {} {string bytelength "\u00c7"}
foo
} 2
test stringComp-8.4 {string bytelength} {
proc foo {} {string b ""}
foo
} 0
## string length
##
test stringComp-9.1 {string length} {
proc foo {} {string length}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test stringComp-9.2 {string length} {
proc foo {} {string length a b}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string length string"}}
test stringComp-9.3 {string length} {
proc foo {} {string length "a little string"}
foo
} 15
test stringComp-9.4 {string length} {
proc foo {} {string le ""}
foo
} 0
test stringComp-9.5 {string length, unicode} {
proc foo {} {string le "abcd\u7266"}
foo
} 5
test stringComp-9.6 {string length, bytearray object} {
proc foo {} {string length [binary format a5 foo]}
foo
} 5
test stringComp-9.7 {string length, bytearray object} {
proc foo {} {string length [binary format I* {0x50515253 0x52}]}
foo
} 8
## string map
## not yet bc
## string match
##
test stringComp-11.1 {string match, too few args} {
proc foo {} {string match a}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test stringComp-11.2 {string match, too many args} {
proc foo {} {string match a b c d}
list [catch {foo} msg] $msg
} {1 {wrong # args: should be "string match ?-nocase? pattern string"}}
test stringComp-11.3 {string match} {
proc foo {} {string match abc abc}
foo
} 1
test stringComp-11.4 {string match} {
proc foo {} {string mat abc abd}
foo
} 0
test stringComp-11.5 {string match} {
proc foo {} {string match ab*c abc}
foo
} 1
test stringComp-11.6 {string match} {
proc foo {} {string match ab**c abc}
foo
} 1
test stringComp-11.7 {string match} {
proc foo {} {string match ab* abcdef}
foo
} 1
test stringComp-11.8 {string match} {
proc foo {} {string match *c abc}
foo
} 1
test stringComp-11.9 {string match} {
proc foo {} {string match *3*6*9 0123456789}
foo
} 1
test stringComp-11.10 {string match} {
proc foo {} {string match *3*6*9 01234567890}
foo
} 0
test stringComp-11.11 {string match} {
proc foo {} {string match a?c abc}
foo
} 1
test stringComp-11.12 {string match} {
proc foo {} {string match a??c abc}
foo
} 0
test stringComp-11.13 {string match} {
proc foo {} {string match ?1??4???8? 0123456789}
foo
} 1
test stringComp-11.14 {string match} {
proc foo {} {string match {[abc]bc} abc}
foo
} 1
test stringComp-11.15 {string match} {
proc foo {} {string match {a[abc]c} abc}
foo
} 1
test stringComp-11.16 {string match} {
proc foo {} {string match {a[xyz]c} abc}
foo
} 0
test stringComp-11.17 {string match} {
proc foo {} {string match {12[2-7]45} 12345}
foo
} 1
test stringComp-11.18 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12345}
foo
} 1
test stringComp-11.19 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12b45}
foo
} 1
test stringComp-11.20 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12d45}
foo
} 1
test stringComp-11.21 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12145}
foo
} 0
test stringComp-11.22 {string match} {
proc foo {} {string match {12[ab2-4cd]45} 12545}
foo
} 0
test stringComp-11.23 {string match} {
proc foo {} {string match {a\*b} a*b}
foo
} 1
test stringComp-11.24 {string match} {
proc foo {} {string match {a\*b} ab}
foo
} 0
test stringComp-11.25 {string match} {
proc foo {} {string match {a\*\?\[\]\\\x} "a*?\[\]\\x"}
foo
} 1
test stringComp-11.26 {string match} {
proc foo {} {string match ** ""}
foo
} 1
test stringComp-11.27 {string match} {
proc foo {} {string match *. ""}
foo
} 0
test stringComp-11.28 {string match} {
proc foo {} {string match "" ""}
foo
} 1
test stringComp-11.29 {string match} {
proc foo {} {string match \[a a}
foo
} 1
test stringComp-11.30 {string match, bad args} {
proc foo {} {string match - b c}
list [catch {foo} msg] $msg
} {1 {bad option "-": must be -nocase}}
test stringComp-11.31 {string match case} {
proc foo {} {string match a A}
foo
} 0
test stringComp-11.32 {string match nocase} {
proc foo {} {string match -n a A}
foo
} 1
test stringComp-11.33 {string match nocase} {
proc foo {} {string match -nocase a\334 A\374}
foo
} 1
test stringComp-11.34 {string match nocase} {
proc foo {} {string match -nocase a*f ABCDEf}
foo
} 1
test stringComp-11.35 {string match case, false hope} {
# This is true because '_' lies between the A-Z and a-z ranges
proc foo {} {string match {[A-z]} _}
foo
} 1
test stringComp-11.36 {string match nocase range} {
# This is false because although '_' lies between the A-Z and a-z ranges,
# we lower case the end points before checking the ranges.
proc foo {} {string match -nocase {[A-z]} _}
foo
} 0
test stringComp-11.37 {string match nocase} {
proc foo {} {string match -nocase {[A-fh-Z]} g}
foo
} 0
test stringComp-11.38 {string match case, reverse range} {
proc foo {} {string match {[A-fh-Z]} g}
foo
} 1
test stringComp-11.39 {string match, *\ case} {
proc foo {} {string match {*\abc} abc}
foo
} 1
test stringComp-11.40 {string match, *special case} {
proc foo {} {string match {*[ab]} abc}
foo
} 0
test stringComp-11.41 {string match, *special case} {
proc foo {} {string match {*[ab]*} abc}
foo
} 1
test stringComp-11.42 {string match, *special case} {
proc foo {} {string match "*\\" "\\"}
foo
} 0
test stringComp-11.43 {string match, *special case} {
proc foo {} {string match "*\\\\" "\\"}
foo
} 1
test stringComp-11.44 {string match, *special case} {
proc foo {} {string match "*???" "12345"}
foo
} 1
test stringComp-11.45 {string match, *special case} {
proc foo {} {string match "*???" "12"}
foo
} 0
test stringComp-11.46 {string match, *special case} {
proc foo {} {string match "*\\*" "abc*"}
foo
} 1
test stringComp-11.47 {string match, *special case} {
proc foo {} {string match "*\\*" "*"}
foo
} 1
test stringComp-11.48 {string match, *special case} {
proc foo {} {string match "*\\*" "*abc"}
foo
} 0
test stringComp-11.49 {string match, *special case} {
proc foo {} {string match "?\\*" "a*"}
foo
} 1
test stringComp-11.50 {string match, *special case} {
proc foo {} {string match "\\" "\\"}
foo
} 0
test stringComp-11.51 {string match; *, -nocase and UTF-8} {
proc foo {} {string match -nocase [binary format I 717316707] \
[binary format I 2028036707]}
foo
} 1
test stringComp-11.52 {string match, null char in string} {
proc foo {} {
set ptn "*abc*"
foreach elem [list "\u0000@abc" "@abc" "\u0000@abc\u0000" "blahabcblah"] {
lappend out [string match $ptn $elem]
}
set out
}
foo
} {1 1 1 1}
test stringComp-11.53 {string match, null char in pattern} {
proc foo {} {
set out ""
foreach {ptn elem} [list \
"*\u0000abc\u0000" "\u0000abc\u0000" \
"*\u0000abc\u0000" "\u0000abc\u0000ef" \
"*\u0000abc\u0000*" "\u0000abc\u0000ef" \
"*\u0000abc\u0000" "@\u0000abc\u0000ef" \
"*\u0000abc\u0000*" "@\u0000abc\u0000ef" \
] {
lappend out [string match $ptn $elem]
}
set out
}
foo
} {1 0 1 0 1}
test stringComp-11.54 {string match, failure} {
proc foo {} {
set longString ""
for {set i 0} {$i < 10} {incr i} {
append longString "abcdefghijklmnopqrstuvwxy\u0000z01234567890123"
}
list [string match *cba* $longString] \
[string match *a*l*\u0000* $longString] \
|
| ︙ | ︙ |
Changes to tests/subst.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: subst # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1994 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
# Commands covered: subst
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1994 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 Ajuba Solutions.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: subst.test,v 1.13.2.7 2004/10/26 21:42:53 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test subst-1.1 {basics} {
|
| ︙ | ︙ | |||
30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
} {}
test subst-2.2 {simple strings} {
subst a
} a
test subst-2.3 {simple strings} {
subst abcdefg
} abcdefg
test subst-3.1 {backslash substitutions} {
subst {\x\$x\[foo bar]\\}
} "x\$x\[foo bar]\\"
test subst-3.2 {backslash substitutions with utf chars} {
# 'j' is just a char that doesn't mean anything, and \344 is 'ä'
# that also doesn't mean anything, but is multi-byte in UTF-8.
| > > > > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
} {}
test subst-2.2 {simple strings} {
subst a
} a
test subst-2.3 {simple strings} {
subst abcdefg
} abcdefg
test subst-2.4 {simple strings} {
# Tcl Bug 685106
subst [bytestring bar\x00soom]
} [bytestring bar\x00soom]
test subst-3.1 {backslash substitutions} {
subst {\x\$x\[foo bar]\\}
} "x\$x\[foo bar]\\"
test subst-3.2 {backslash substitutions with utf chars} {
# 'j' is just a char that doesn't mean anything, and \344 is 'ä'
# that also doesn't mean anything, but is multi-byte in UTF-8.
|
| ︙ | ︙ | |||
211 212 213 214 215 216 217 218 219 220 221 |
} {foo set a {}{} ; stuff] bar}
test subst-11.5 {continue in a subst, parse error} {
subst {foo [continue ;set bar baz ;set a {}{} ; stuff] bar}
} {foo set bar baz ;set a {}{} ; stuff] bar}
test subst-11.6 {continue in a variable subst} {
subst {foo $var([continue]) bar}
} {foo bar}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 |
} {foo set a {}{} ; stuff] bar}
test subst-11.5 {continue in a subst, parse error} {
subst {foo [continue ;set bar baz ;set a {}{} ; stuff] bar}
} {foo set bar baz ;set a {}{} ; stuff] bar}
test subst-11.6 {continue in a variable subst} {
subst {foo $var([continue]) bar}
} {foo bar}
test subst-12.1 {nasty case, Bug 1036649} {
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[subst {};"} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
set res
} {1 {missing close-bracket}}
test subst-12.2 {nasty case, Bug 1036649} {
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[subst {}; "} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
set res
} {1 {missing close-bracket}}
test subst-12.3 {nasty case, Bug 1036649} {
set x 0
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[incr x;"} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
list $res $x
} {{1 {missing close-bracket}} 10}
test subst-12.4 {nasty case, Bug 1036649} {
set x 0
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[incr x; "} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
list $res $x
} {{1 {missing close-bracket}} 10}
test subst-12.5 {nasty case, Bug 1036649} {
set x 0
for {set i 0} {$i < 10} {incr i} {
set res [list [catch {subst "\[incr x"} msg] $msg]
if {$msg ne "missing close-bracket"} break
}
list $res $x
} {{1 {missing close-bracket}} 0}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/tcltest.test.
1 2 3 4 5 6 7 8 | # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # # RCS: @(#) $Id: tcltest.test,v 1.37.2.11 2006/03/19 22:47:30 vincentdarley Exp $ # Note that there are several places where the value of # tcltest::currentFailure is stored/reset in the -setup/-cleanup # of a test that has a body that runs [test] that will fail. # This is a workaround of using the same tcltest code that we are # testing to run the test itself. Ditto on things like [verbose]. # |
| ︙ | ︙ | |||
521 522 523 524 525 526 527 |
puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
exit
} a.tcl]
set tdiaf [makeFile {} thisdirectoryisafile]
set normaldirectory [makeDirectory normaldirectory]
| < | < | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
exit
} a.tcl]
set tdiaf [makeFile {} thisdirectoryisafile]
set normaldirectory [makeDirectory normaldirectory]
normalizePath normaldirectory
# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
file delete -force thisdirectorydoesnotexist
slave msg $a -tmpdir thisdirectorydoesnotexist
list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
[file delete -force thisdirectorydoesnotexist]
|
| ︙ | ︙ | |||
556 557 558 559 560 561 562 563 564 565 |
switch $tcl_platform(platform) {
"unix" {
file attributes $notReadableDir -permissions 00333
file attributes $notWriteableDir -permissions 00555
}
default {
catch {file attributes $notWriteableDir -readonly 1}
}
}
| > | | | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 |
switch $tcl_platform(platform) {
"unix" {
file attributes $notReadableDir -permissions 00333
file attributes $notWriteableDir -permissions 00555
}
default {
catch {file attributes $notWriteableDir -readonly 1}
catch {testchmod 000 $notWriteableDir}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unix notRoot} {
slave msg $a -tmpdir $notReadableDir
string match {*not readable*} $msg
} {1}
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc notRoot} {
slave msg $a -tmpdir $notWriteableDir
string match {*not writeable*} $msg
} {1}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
slave msg $a -tmpdir $normaldirectory
# The join is necessary because the message can be split on multiple lines
|
| ︙ | ︙ | |||
619 620 621 622 623 624 625 |
} {1}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
slave msg $a -testdir $tdiaf
string match "*not a directory*" $msg
} {1}
| | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
} {1}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
slave msg $a -testdir $tdiaf
string match "*not a directory*" $msg
} {1}
test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unix notRoot} {
slave msg $a -testdir $notReadableDir
string match {*not readable*} $msg
} {1}
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
slave msg $a -testdir $normaldirectory
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 | file delete -force $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] | | > > > | > > > | | | > > > | | | > > | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 |
file delete -force $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
removeDirectory normaldirectory
# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
slave msg [file join [testsDirectory] all.tcl] -file d*.test
set msg
} -cleanup {
testsDirectory $old
} -match regexp -result {dstring\.test}
test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup {
set old [testsDirectory]
testsDirectory [file dirname [info script]]
} -body {
slave msg [file join [testsDirectory] all.tcl] \
-file d*.test -notfile dstring*
regexp {dstring\.test} $msg
} -cleanup {
testsDirectory $old
} -result 0
test tcltest-9.3 {matchFiles} {
-body {
set old [matchFiles]
matchFiles foo
set current [matchFiles]
matchFiles bar
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 739 740 741 742 743 744 745 |
skipFiles bar
set new [skipFiles]
skipFiles $old
list $current $new
}
-result {foo bar}
}
# -preservecore, [preserveCore]
set mc [makeFile {
package require tcltest
namespace import ::tcltest::test
test makecore {make a core file} {
set f [open core w]
| > > > > > > > > > > > > > > > | 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
skipFiles bar
set new [skipFiles]
skipFiles $old
list $current $new
}
-result {foo bar}
}
test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
set d [makeDirectory tmp]
makeDirectory foo $d
makeFile {} fee $d
file copy [file join [file dirname [info script]] all.tcl] $d
} -body {
slave msg [file join [temporaryDirectory] all.tcl] -file f*
regexp {exiting with errors:} $msg
} -cleanup {
file delete [file join $d all.tcl]
removeFile fee $d
removeDirectory foo $d
removeDirectory tmp
} -result 0
# -preservecore, [preserveCore]
set mc [makeFile {
package require tcltest
namespace import ::tcltest::test
test makecore {make a core file} {
set f [open core w]
|
| ︙ | ︙ | |||
809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 |
[regexp {tcltest} [join [list $msg] [split $msg \n]]] \
[regexp {loadScript} [join [list $msg] [split $msg \n]]]
} {1 1}
test tcltest-12.3 {loadScript} {
-setup {
set old $::tcltest::loadScript
}
-body {
set f1 [loadScript]
set f2 [loadScript xxx]
set f3 [loadScript]
list $f1 $f2 $f3
}
-result {{} xxx xxx}
-cleanup {
set ::tcltest::loadScript $old
}
}
test tcltest-12.4 {loadFile} {
-setup {
set olds $::tcltest::loadScript
set oldf $::tcltest::loadFile
set ::tcltest::loadFile {}
}
-body {
set f1 [loadScript]
set f2 [loadFile]
set f3 [loadFile $loadfile]
| > > | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 |
[regexp {tcltest} [join [list $msg] [split $msg \n]]] \
[regexp {loadScript} [join [list $msg] [split $msg \n]]]
} {1 1}
test tcltest-12.3 {loadScript} {
-setup {
set old $::tcltest::loadScript
set ::tcltest::loadScript {}
}
-body {
set f1 [loadScript]
set f2 [loadScript xxx]
set f3 [loadScript]
list $f1 $f2 $f3
}
-result {{} xxx xxx}
-cleanup {
set ::tcltest::loadScript $old
}
}
test tcltest-12.4 {loadFile} {
-setup {
set olds $::tcltest::loadScript
set ::tcltest::loadScript {}
set oldf $::tcltest::loadFile
set ::tcltest::loadFile {}
}
-body {
set f1 [loadScript]
set f2 [loadFile]
set f3 [loadFile $loadfile]
|
| ︙ | ︙ | |||
965 966 967 968 969 970 971 |
[file join $dtd all.tcl] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
| | | | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 |
[file join $dtd all.tcl] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]}
}
test tcltest-15.2 {-asidefromdir} {
-constraints {unixOrPc}
-body {
if {[slave msg \
[file join $dtd all.tcl] \
-asidefromdir dirtestdir2.3 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[12].*Tests located in:.*dirtestdir2.[12].*dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Error: No test files remain after applying your match and skip patterns!
Error: No test files remain after applying your match and skip patterns!
Error: No test files remain after applying your match and skip patterns!$}
}
test tcltest-15.3 {-relateddir, non-existent dir} {
-constraints {unixOrPc}
|
| ︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 | } removeDirectory dirtestdir2.3 $dtd removeDirectory dirtestdir2.2 $dtd removeDirectory dirtestdir2.1 $dtd removeDirectory dirtestdir # TCLTEST_OPTIONS | | < < < | | < > > > | > > < < | > | > | < < | | < | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 |
}
removeDirectory dirtestdir2.3 $dtd
removeDirectory dirtestdir2.2 $dtd
removeDirectory dirtestdir2.1 $dtd
removeDirectory dirtestdir
# TCLTEST_OPTIONS
test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
if {[info exists ::env(TCLTEST_OPTIONS)]} {
set oldoptions $::env(TCLTEST_OPTIONS)
} else {
set oldoptions none
}
# set this to { } instead of just {} to get around quirk in
# Windows env handling that removes empty elements from env array.
set ::env(TCLTEST_OPTIONS) { }
interp create slave1
slave1 eval [list set argv {-debug 2}]
slave1 alias puts puts
interp create slave2
slave2 alias puts puts
} -cleanup {
interp delete slave2
interp delete slave1
if {$oldoptions == "none"} {
unset ::env(TCLTEST_OPTIONS)
} else {
set ::env(TCLTEST_OPTIONS) $oldoptions
}
} -body {
slave1 eval [package ifneeded tcltest [package provide tcltest]]
slave1 eval tcltest::debug
set ::env(TCLTEST_OPTIONS) "-debug 3"
slave2 eval [package ifneeded tcltest [package provide tcltest]]
slave2 eval tcltest::debug
} -result {^3$} -match regexp -output\
{tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
# Begin testing of tcltest procs ...
cd [temporaryDirectory]
# PrintError
test tcltest-20.1 {PrintError} {unixOrPc} {
set result [slave msg $printerror]
|
| ︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 1721 |
} -body {
puts -nonewline stdout bla
puts -nonewline stdout bla
} -output {blabla}
test tcltest-25.3 {
reported return code (Bug 611922)
} -body {
| > > > < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 |
} -body {
puts -nonewline stdout bla
puts -nonewline stdout bla
} -output {blabla}
test tcltest-25.3 {
reported return code (Bug 611922)
} -setup {
set fail $::tcltest::currentFailure
set v [verbose]
} -body {
verbose {}
test tcltest-25.3.0 {} -body {
error foo
}
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
} -match glob -output {*generated error; Return code was: 1*}
test tcltest-26.1 {Bug/RFE 1017151} -setup {
makeFile {
package require tcltest
set errorInfo "Should never see this"
tcltest::test tcltest-26.1.0 {
no errorInfo when only return code mismatch
} -body {
set x 1
} -returnCodes error -result 1
tcltest::cleanupTests
} test.tcl
} -body {
slave msg [file join [temporaryDirectory] test.tcl]
set msg
} -cleanup {
removeFile test.tcl
} -match glob -result {*
---- Return code should have been one of: 1
==== tcltest-26.1.0 FAILED*}
test tcltest-26.2 {Bug/RFE 1017151} -setup {
makeFile {
package require tcltest
set errorInfo "Should never see this"
tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body {
error "body error"
} -cleanup {
error "cleanup error"
} -result 1
tcltest::cleanupTests
} test.tcl
} -body {
slave msg [file join [temporaryDirectory] test.tcl]
set msg
} -cleanup {
removeFile test.tcl
} -match glob -result {*
---- errorInfo: body error
*
---- errorInfo(cleanup): cleanup error*}
cleanupTests
}
namespace delete ::tcltest::test
return
|
Changes to tests/timer.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: timer.test,v 1.7.22.2 2005/11/09 21:46:20 kennykb Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
test timer-1.1 {Tcl_CreateTimerHandler procedure} {
foreach i [after info] {
after cancel $i
}
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
}}
interp delete x
set x before
after 300
update
set x
} {before after2 after4}
| | > > > > > > | > | | | | | | | | | | | | > > | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
}}
interp delete x
set x before
after 300
update
set x
} {before after2 after4}
test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup {
interp create slave
slave eval namespace export after
slave eval namespace eval foo namespace import ::after
} -body {
slave eval foo::after 1
slave eval namespace origin foo::after
} -cleanup {
# Bug will cause crash here; would cause failure otherwise
interp delete slave
} -result ::after
test timer-11.2 {Bug 1350293: [after] negative argument} \
-body {
set l {}
after 100 {lappend l 100; set done 1}
after -1 {lappend l -1}
vwait done
set l
} \
-result {-1 100}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/trace.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: trace # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
# Commands covered: trace
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: trace.test,v 1.26.2.17 2006/11/04 01:37:56 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testevalobjv [llength [info commands testevalobjv]]
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
}
proc traceScalar {name1 name2 op} {
global info
set info [list $name1 $name2 $op [catch {uplevel set $name1} msg] $msg]
}
proc traceScalarAppend {name1 name2 op} {
global info
|
| ︙ | ︙ | |||
709 710 711 712 713 714 715 |
} {0 xyzzy}
test trace-12.8 {errors when setting variable traces} {
catch {unset x}
set x 44
list [catch {trace add variable x(0) write traceProc} msg] $msg
} {1 {can't trace "x(0)": variable isn't array}}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 |
} {0 xyzzy}
test trace-12.8 {errors when setting variable traces} {
catch {unset x}
set x 44
list [catch {trace add variable x(0) write traceProc} msg] $msg
} {1 {can't trace "x(0)": variable isn't array}}
# Check trace deletion
test trace-13.1 {delete one trace from another} {
proc delTraces {args} {
global x
trace remove variable x read {traceTag 2}
trace remove variable x read {traceTag 3}
trace remove variable x read {traceTag 4}
}
catch {unset x}
set x 44
set info {}
trace add variable x read {traceTag 1}
trace add variable x read {traceTag 2}
trace add variable x read {traceTag 3}
trace add variable x read {traceTag 4}
trace add variable x read delTraces
trace add variable x read {traceTag 5}
set x
set info
} {5 1}
test trace-13.2 {leak when unsetting traced variable} \
-constraints memory -body {
set end [getbytes]
proc f args {}
for {set i 0} {$i < 5} {incr i} {
trace add variable bepa write f
set bepa a
unset bepa
set tmp $end
set end [getbytes]
}
expr {$end - $tmp}
} -cleanup {
unset -nocomplain end i tmp
} -result 0
test trace-13.3 {leak when removing traces} \
-constraints memory -body {
set end [getbytes]
proc f args {}
for {set i 0} {$i < 5} {incr i} {
trace add variable bepa write f
set bepa a
trace remove variable bepa write f
set tmp $end
set end [getbytes]
}
expr {$end - $tmp}
} -cleanup {
unset -nocomplain end i tmp
} -result 0
test trace-13.4 {leaks in error returns from traces} \
-constraints memory -body {
set end [getbytes]
for {set i 0} {$i < 5} {incr i} {
set apa {a 1 b 2}
set bepa [lrange $apa 0 end]
trace add variable bepa write {error hej}
catch {set bepa a}
unset bepa
set tmp $end
set end [getbytes]
}
expr {$end - $tmp}
} -cleanup {
unset -nocomplain end i tmp
} -result 0
# Check operation and syntax of "trace" command.
# Syntax for adding/removing variable and command traces is basically the
# same:
# trace add variable name opList command
# trace remove variable name opList command
|
| ︙ | ︙ | |||
824 825 826 827 828 829 830 |
list [catch {trace variable x y z w} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.11 {trace command, "trace variable" errors} {
list [catch {trace variable x y z} msg] $msg
} [list 1 "bad operations \"y\": should be one or more of rwua"]
| | | | | | | | | | | 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 |
list [catch {trace variable x y z w} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.11 {trace command, "trace variable" errors} {
list [catch {trace variable x y z} msg] $msg
} [list 1 "bad operations \"y\": should be one or more of rwua"]
test trace-14.12 {trace command ("remove variable" option)} {
catch {unset x}
set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
} {}
test trace-14.13 {trace command ("remove variable" option)} {
catch {unset x}
set info {}
trace add variable x write traceProc
trace remove variable x write traceProc
set x 12345
set info
} {}
test trace-14.14 {trace command ("remove variable" option)} {
catch {unset x}
set info {}
trace add variable x write {traceTag 1}
trace add variable x write traceProc
trace add variable x write {traceTag 2}
set x yy
trace remove variable x write traceProc
set x 12345
trace remove variable x write {traceTag 1}
set x foo
trace remove variable x write {traceTag 2}
set x gorp
set info
} {2 x {} write 1 2 1 2}
test trace-14.15 {trace command ("remove variable" option)} {
catch {unset x}
set info {}
trace add variable x write {traceTag 1}
trace remove variable x write non_existent
set x 12345
set info
} {1}
test trace-14.16 {trace command ("info variable" option)} {
catch {unset x}
trace add variable x write {traceTag 1}
trace add variable x write traceProc
trace add variable x write {traceTag 2}
trace info variable x
} {{write {traceTag 2}} {write traceProc} {write {traceTag 1}}}
test trace-14.17 {trace command ("info variable" option)} {
catch {unset x}
trace info variable x
} {}
test trace-14.18 {trace command ("info variable" option)} {
catch {unset x}
trace info variable x(0)
} {}
test trace-14.19 {trace command ("info variable" option)} {
catch {unset x}
set x 44
trace info variable x(0)
} {}
test trace-14.20 {trace command ("info variable" option)} {
catch {unset x}
set x 44
trace add variable x write {traceTag 1}
proc check {} {global x; trace info variable x}
check
} {{write {traceTag 1}}}
|
| ︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 |
proc p1 args {
trace vdelete ::foo::x u p1
}
trace variable ::foo::x u p1
namespace delete ::foo
info exists ::foo::x
} 0
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
catch {unset x}
catch {unset y}
| > > > > > > > > > > > > > > > > > > > > | | | 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
proc p1 args {
trace vdelete ::foo::x u p1
}
trace variable ::foo::x u p1
namespace delete ::foo
info exists ::foo::x
} 0
test trace-18.3 {namespace delete / trace vdelete combo, Bug \#1337229} {
namespace eval ::ns {}
trace add variable ::ns::var unset {unset ::ns::var ;#}
namespace delete ::ns
} {}
test trace-18.4 {namespace delete / trace vdelete combo, Bug \#1338280} {
namespace eval ::ref {}
set ::ref::var1 AAA
trace add variable ::ref::var1 unset doTrace
set ::ref::var2 BBB
trace add variable ::ref::var2 {unset} doTrace
proc doTrace {vtraced vidx op} {
global info
append info [catch {set ::$vtraced}][llength [info vars ::ref::*]]
}
set info {}
namespace delete ::ref
rename doTrace {}
set info
} 1110
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
catch {unset x}
catch {unset y}
test trace-19.0.1 {trace add command (command existence)} {
# Just in case!
catch {rename nosuchname ""}
list [catch {trace add command nosuchname rename traceCommand} msg] $msg
} {1 {unknown command "nosuchname"}}
test trace-19.0.2 {trace add command (command existence in ns)} {
list [catch {trace add command nosuchns::nosuchname rename traceCommand} msg] $msg
} {1 {unknown command "nosuchns::nosuchname"}}
test trace-19.1 {trace add command (rename option)} {
proc foo {} {}
catch {rename bar {}}
|
| ︙ | ︙ | |||
1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 |
catch {rename someothername {}}
trace add command foo delete [list traceCmdrename foo]
rename foo bar
rename bar {}
# None of these should exist.
list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}
proc foo {b} { set a $b }
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
| > > > > > > > > > > > > > > > > > > > > > | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 |
catch {rename someothername {}}
trace add command foo delete [list traceCmdrename foo]
rename foo bar
rename bar {}
# None of these should exist.
list [info commands foo] [info commands bar] [info commands someothername]
} {{} {} {}}
test trace-20.13 {rename trace discards result [Bug 1355342]} {
proc foo {} {}
trace add command foo rename {set w Aha!;#}
list [rename foo bar] [rename bar {}]
} {{} {}}
test trace-20.14 {rename trace discards error result [Bug 1355342]} {
proc foo {} {}
trace add command foo rename {error}
list [rename foo bar] [rename bar {}]
} {{} {}}
test trace-20.15 {delete trace discards result [Bug 1355342]} {
proc foo {} {}
trace add command foo delete {set w Aha!;#}
rename foo {}
} {}
test trace-20.16 {delete trace discards error result [Bug 1355342]} {
proc foo {} {}
trace add command foo delete {error}
rename foo {}
} {}
proc foo {b} { set a $b }
# Delete arrays when done, so they can be re-used as scalars
# elsewhere.
|
| ︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 |
test trace-21.8 {trace execution: leavestep} {
set info {}
trace add execution foo {leavestep} [list traceExecute foo]
foo 3
trace remove execution foo {leavestep} [list traceExecute foo]
set info
} {{foo {set b 3} 0 3 leavestep}}
proc factorial {n} {
if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
return 1
}
test trace-22.1 {recursive(1) trace execution: enter} {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 |
test trace-21.8 {trace execution: leavestep} {
set info {}
trace add execution foo {leavestep} [list traceExecute foo]
foo 3
trace remove execution foo {leavestep} [list traceExecute foo]
set info
} {{foo {set b 3} 0 3 leavestep}}
test trace-21.9 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {
trace add execution foo enter soom
proc ::soom args {lappend ::info SUCCESS [info level]}
set ::info {}
namespace eval test_ns_1 {
proc soom args {lappend ::info FAIL [info level]}
# [testevalobjv 1 ...] ought to produce the same
# results as [uplevel #0 ...].
testevalobjv 1 foo x
uplevel #0 foo x
}
namespace delete test_ns_1
trace remove execution foo enter soom
set ::info
} {SUCCESS 1 SUCCESS 1}
test trace-21.10 {trace execution: TCL_EVAL_GLOBAL} testevalobjv {
trace add execution foo leave soom
proc ::soom args {lappend ::info SUCCESS [info level]}
set ::info {}
namespace eval test_ns_1 {
proc soom args {lappend ::info FAIL [info level]}
# [testevalobjv 1 ...] ought to produce the same
# results as [uplevel #0 ...].
testevalobjv 1 foo x
uplevel #0 foo x
}
namespace delete test_ns_1
trace remove execution foo leave soom
set ::info
} {SUCCESS 1 SUCCESS 1}
test trace-21.11 {trace execution and alias} -setup {
set res {}
proc ::x {} {return ::}
namespace eval a {}
proc ::a::x {} {return ::a}
interp alias {} y {} x
} -body {
lappend res [namespace eval ::a y]
trace add execution ::x enter {
rename ::x {}
proc ::x {} {return ::}
#}
lappend res [namespace eval ::a y]
} -cleanup {
namespace delete a
rename ::x {}
} -result {:: ::}
proc factorial {n} {
if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }
return 1
}
test trace-22.1 {recursive(1) trace execution: enter} {
|
| ︙ | ︙ | |||
1976 1977 1978 1979 1980 1981 1982 |
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} 2 error leavestep
foo foo 0 error leave}}
| | > | 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 |
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} 2 error leavestep
foo foo 0 error leave}}
test trace-28.4 {exec traces in slave with 'return -code error'} {
interp create slave
interp alias slave traceExecute {} traceExecute
set info {}
set res [interp eval slave {
set info {}
set res {}
proc foo {} {
if {[catch {bar}]} {
return "error"
|
| ︙ | ︙ | |||
2005 2006 2007 2008 2009 2010 2011 |
# With the trace active
lappend res [foo]
trace remove execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
| | | | | | | | | | | | 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 |
# With the trace active
lappend res [foo]
trace remove execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
list $res
}]
interp delete slave
lappend res [join $info \n]
} {{error error} {foo foo enter
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} enterstep
foo {catch bar} enterstep
foo bar enterstep
foo {return -code error msg} enterstep
foo {return -code error msg} 2 msg leavestep
foo bar 1 msg leavestep
foo {catch bar} 0 1 leavestep
foo {return error} enterstep
foo {return error} 2 error leavestep
foo {if {[catch {bar}]} {
return "error"
} else {
return "ok"
}} 2 error leavestep
foo foo 0 error leave}}
test trace-28.5 {exec traces} {
set info {}
proc foo {args} { set a 1 }
trace add execution foo {enter enterstep leave leavestep} \
[list traceExecute foo]
|
| ︙ | ︙ | |||
2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 |
test trace-28.9 {exec trace info nonsense} {
list [catch {trace info execution thisdoesntexist} res] $res
} {1 {unknown command "thisdoesntexist"}}
test trace-28.10 {exec trace info nonsense} {
list [catch {trace remove execution} res] $res
} {1 {wrong # args: should be "trace remove execution name opList command"}}
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}
catch {rename foo {}}
catch {rename bar {}}
# Unset the varaible when done
catch {unset info}
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 |
test trace-28.9 {exec trace info nonsense} {
list [catch {trace info execution thisdoesntexist} res] $res
} {1 {unknown command "thisdoesntexist"}}
test trace-28.10 {exec trace info nonsense} {
list [catch {trace remove execution} res] $res
} {1 {wrong # args: should be "trace remove execution name opList command"}}
# Missing test number to keep in sync with the 8.5 branch
# (want to backport those tests?)
test trace-31.1 {command and execution traces shared struct} {
# Tcl Bug 807243
proc foo {} {}
trace add command foo delete foo
trace add execution foo enter foo
set result [trace info command foo]
trace remove command foo delete foo
trace remove execution foo enter foo
rename foo {}
set result
} [list [list delete foo]]
test trace-31.2 {command and execution traces shared struct} {
# Tcl Bug 807243
proc foo {} {}
trace add command foo delete foo
trace add execution foo enter foo
set result [trace info execution foo]
trace remove command foo delete foo
trace remove execution foo enter foo
rename foo {}
set result
} [list [list enter foo]]
test trace-32.1 {
TraceCommandInfo refcount decr in TraceCommandProc w/o loss of reference
} {
# Tcl Bug 811483
proc foo {} {}
trace add command foo delete foo
trace add execution foo enter foo
set result [trace info command foo]
rename foo {}
set result
} [list [list delete foo]]
test trace-33.1 {variable match with remove variable} {
unset -nocomplain x
trace variable x w foo
trace remove variable x write foo
llength [trace info variable x]
} 0
test trace-34.1 {Bug 1201035} {
set ::x [list]
proc foo {} {lappend ::x foo}
proc bar args {
lappend ::x $args
trace remove execution foo leavestep bar
trace remove execution foo enterstep bar
trace add execution foo leavestep bar
trace add execution foo enterstep bar
lappend ::x done
}
trace add execution foo leavestep bar
trace add execution foo enterstep bar
foo
set ::x
} {{{lappend ::x foo} enterstep} done foo}
test trace-34.2 {Bug 1224585} {
proc foo {} {}
proc bar args {trace remove execution foo leave soom}
trace add execution foo leave bar
trace add execution foo leave soom
foo
} {}
test trace-34.3 {Bug 1224585} {
proc foo {} {set x {}}
proc bar args {trace remove execution foo enterstep soom}
trace add execution foo enterstep soom
trace add execution foo enterstep bar
foo
} {}
# We test here for the half-documented and currently valid interplay between
# delete traces and namespace deletion.
test trace-34.4 {Bug 1047286} {
variable x notrace
proc callback {old - -} {
variable x "$old exists: [namespace which -command $old]"
}
namespace eval ::foo {proc bar {} {}}
trace add command ::foo::bar delete [namespace code callback]
namespace delete ::foo
set x
} {::foo::bar exists: ::foo::bar}
test trace-34.5 {Bug 1047286} {
variable x notrace
proc callback {old - -} {
variable x "$old exists: [namespace which -command $old]"
}
namespace eval ::foo {proc bar {} {}}
trace add command ::foo::bar delete [namespace code callback]
namespace eval ::foo namespace delete ::foo
set x
} {::foo::bar exists: }
test trace-34.6 {Bug 1458266} -setup {
proc dummy {} {}
proc stepTraceHandler {cmdString args} {
variable log
append log "[expr {[info level] - 1}]: [lindex [split $cmdString] 0]\n"
dummy
isTracedInside_2
}
proc cmdTraceHandler {cmdString args} {
# silent
}
proc isTracedInside_1 {} {
isTracedInside_2
}
proc isTracedInside_2 {} {
set x 2
}
} -body {
variable log {}
trace add execution isTracedInside_1 enterstep stepTraceHandler
trace add execution isTracedInside_2 enterstep stepTraceHandler
isTracedInside_1
variable first $log
set log {}
trace add execution dummy enter cmdTraceHandler
isTracedInside_1
variable second $log
expr {($first eq $second) ? "ok" : "\n$first\nand\n\n$second\ndiffer"}
} -cleanup {
unset -nocomplain log first second
rename dummy {}
rename stepTraceHandler {}
rename cmdTraceHandler {}
rename isTracedInside_1 {}
rename isTracedInside_2 {}
} -result ok
# Delete procedures when done, so we don't clash with other tests
# (e.g. foobar will clash with 'unknown' tests).
catch {rename foobar {}}
catch {rename foo {}}
catch {rename bar {}}
# Unset the varaible when done
catch {unset info}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/unixFCmd.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file tests the tclUnixFCmd.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996 Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file tests the tclUnixFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixFCmd.test,v 1.17.2.1 2003/04/14 15:45:57 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# These tests really need to be run from a writable directory, which
|
| ︙ | ︙ | |||
281 282 283 284 285 286 287 |
} {1 {could not set permissions for file "foo.test": no such file or directory}}
test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -permissions foo} msg] $msg \
[file delete -force -- foo.test]
} {1 {unknown permission string format "foo"} {}}
| | | | | | | | | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
} {1 {could not set permissions for file "foo.test": no such file or directory}}
test unixFCmd-17.3 {SetPermissionsAttribute} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -permissions foo} msg] $msg \
[file delete -force -- foo.test]
} {1 {unknown permission string format "foo"} {}}
test unixFCmd-17.4 {SetPermissionsAttribute} {unixOnly notRoot} {
catch {file delete -force -- foo.test}
close [open foo.test w]
list [catch {file attributes foo.test -permissions ---rwx} msg] $msg \
[file delete -force -- foo.test]
} {1 {unknown permission string format "---rwx"} {}}
close [open foo.test w]
set ::i 4
proc permcheck {testnum permstr expected} {
test $testnum {SetPermissionsAttribute} {unixOnly notRoot} {
file attributes foo.test -permissions $permstr
file attributes foo.test -permissions
} $expected
}
permcheck unixFCmd-17.5 rwxrwxrwx 00777
permcheck unixFCmd-17.6 r--r---w- 00442
permcheck unixFCmd-17.7 0 00000
permcheck unixFCmd-17.8 u+rwx,g+r 00740
permcheck unixFCmd-17.9 u-w 00540
permcheck unixFCmd-17.10 o+rwx 00547
permcheck unixFCmd-17.11 --x--x--x 00111
permcheck unixFCmd-17.12 a+rwx 00777
file delete -force -- foo.test
test unixFCmd-18.1 {Unix pwd} {nonPortable unixOnly notRoot} {
# This test is nonportable because SunOS generates a weird error
# message when the current directory isn't readable.
set cd [pwd]
set nd $cd/tstdir
|
| ︙ | ︙ |
Changes to tests/unixInit.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # The file tests the functions in the tclUnixInit.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
# The file tests the functions in the tclUnixInit.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixInit.test,v 1.30.2.12 2005/04/27 21:07:52 dgp Exp $
package require tcltest 2
namespace import -force ::tcltest::*
unset -nocomplain path
if {[info exists env(TCL_LIBRARY)]} {
set oldlibrary $env(TCL_LIBRARY)
unset env(TCL_LIBRARY)
}
catch {set oldlang $env(LANG)}
set env(LANG) C
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
set x [lrange [getlibpath /tmp/sparkly/tcltest] 0 4]
file delete -force /tmp/sparkly
file delete -force /tmp/library
set x
} [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
/tmp/library /library /tcl[info patchlevel]/library]
test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
unixOnly stdio
} -body {
set env(LANG) C
set f [open "|[list [interpreter]]" w+]
fconfigure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
unset env(LANG)
set enc
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 |
set x [lrange [getlibpath /tmp/sparkly/tcltest] 0 4]
file delete -force /tmp/sparkly
file delete -force /tmp/library
set x
} [list /tmp/lib/tcl[info tclversion] /lib/tcl[info tclversion] \
/tmp/library /library /tcl[info patchlevel]/library]
test unixInit-2.10 {TclpInitLibraryPath: executable relative} -constraints {
unixOnly stdio
} -setup {
set tmpDir [makeDirectory tmp]
set sparklyDir [makeDirectory sparkly $tmpDir]
set execPath [file join [makeDirectory bin $sparklyDir] tcltest]
file copy [interpreter] $execPath
set libDir [makeDirectory lib $sparklyDir]
set scriptDir [makeDirectory tcl[info tclversion] $libDir]
makeFile {} init.tcl $scriptDir
set saveDir [pwd]
cd $libDir
} -body {
# Checking for Bug 832657
set x [lrange [getlibpath [file join .. bin tcltest]] 2 3]
foreach p $x {
lappend y [file normalize $p]
}
set y
} -cleanup {
cd $saveDir
unset saveDir
removeFile init.tcl $scriptDir
unset scriptDir
removeDirectory tcl[info tclversion] $libDir
unset libDir
file delete $execPath
unset execPath
removeDirectory bin $sparklyDir
removeDirectory lib $sparklyDir
unset sparklyDir
removeDirectory sparkly $tmpDir
unset tmpDir
removeDirectory tmp
unset x p y
} -result [list [file join [temporaryDirectory] tmp sparkly library] \
[file join [temporaryDirectory] tmp library] ]
test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
unixOnly stdio
} -body {
set env(LANG) C
set f [open "|[list [interpreter]]" w+]
fconfigure $f -buffering none
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
unset env(LANG)
set enc
} -match regexp -result [expr {
($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}]
test unixInit-3.2 {TclpSetInitialEncodings} {unixOnly stdio} {
set env(LANG) japanese
catch {set oldlc_all $env(LC_ALL)}
set env(LC_ALL) japanese
set f [open "|[list [interpreter]]" w+]
fconfigure $f -buffering none
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
# Some older HP-UX systems need us to accept this as valid
# Bug 453883 reports that newer HP-UX systems report euc-jp
# like everybody else.
lappend validEncodings shiftjis
}
expr {[lsearch -exact $validEncodings $enc] < 0}
} 0
| | > > > > > > > > > > > > > > > > < | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
# Some older HP-UX systems need us to accept this as valid
# Bug 453883 reports that newer HP-UX systems report euc-jp
# like everybody else.
lappend validEncodings shiftjis
}
expr {[lsearch -exact $validEncodings $enc] < 0}
} 0
test unixInit-4.1 {TclpSetVariables} {unixOnly} {
# just make sure they exist
set a [list $tcl_library $tcl_pkgPath $tcl_platform(os)]
set a [list $tcl_platform(osVersion) $tcl_platform(machine)]
set tcl_platform(platform)
} "unix"
test unixInit-5.1 {Tcl_Init} {emptyTest unixOnly} {
# test initScript
} {}
test unixInit-6.1 {Tcl_SourceRCFile} {emptyTest unixOnly} {
} {}
test unixInit-7.1 {closed standard channel: Bug 772288} -constraints {
unixOnly stdio
} -body {
set tclsh [interpreter]
set crash [makeFile {puts [open /dev/null]} crash.tcl]
set crashtest [makeFile "
close stdin
[list exec $tclsh $crash]
" crashtest.tcl]
exec $tclsh $crashtest
} -cleanup {
removeFile crash.tcl
removeFile crashtest.tcl
} -returnCodes 0
# cleanup
if {[info exists oldlibrary]} {
set env(TCL_LIBRARY) $oldlibrary
}
catch {unset env(LANG)}
catch {set env(LANG) $oldlang}
unset -nocomplain path
::tcltest::cleanupTests
return
|
Changes to tests/unixNotfy.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file contains tests for tclUnixNotfy.c. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 by Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | > > > > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
# This file contains tests for tclUnixNotfy.c.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: unixNotfy.test,v 1.11.2.4 2005/05/14 20:52:31 das Exp $
# The tests should not be run if you have a notifier which is unable to
# detect infinite vwaits, as the tests below will hang. The presence of
# the "testthread" command indicates that this is the case.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[info exists tk_version]} {
puts "When run in a Tk shell, these tests run hang. Skipping tests ..."
::tcltest::cleanupTests
return
}
set ::tcltest::testConstraints(testthread) \
[expr {[info commands testthread] != {}}]
# Darwin always uses a threaded notifier
testConstraint unthreaded [expr {
(![info exist tcl_platform(threaded)] || !$tcl_platform(threaded))
&& $tcl_platform(os) ne "Darwin"
}]
# The next two tests will hang if threads are enabled because the notifier
# will not necessarily wait for ever in this case, so it does not generate
# an error.
test unixNotfy-1.1 {Tcl_DeleteFileHandler} \
-constraints {unixOnly && unthreaded} \
-body {
catch {vwait x}
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
list [catch {vwait x} msg] $msg
} \
-result {1 {can't wait for variable "x": would wait forever}} \
-cleanup {
catch { close $f }
catch { removeFile foo }
}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} \
-constraints {unixOnly && unthreaded} \
-body {
catch {vwait x}
set f1 [open [makeFile "" foo] w]
set f2 [open [makeFile "" foo2] w]
fileevent $f1 writable {set x 1}
fileevent $f2 writable {set y 1}
vwait x
|
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
catch { close $f1 }
catch { close $f2 }
catch { removeFile foo }
catch { removeFile foo2 }
}
test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
| | | < < > | | < < | > | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
catch { close $f1 }
catch { close $f2 }
catch { removeFile foo }
catch { removeFile foo2 }
}
test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
-constraints {unixOnly testthread} \
-body {
update
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
testthread create "testthread send [testthread id] {set x ok}"
vwait x
threadReap
set x
} \
-result {ok} \
-cleanup {
catch { close $f }
catch { removeFile foo }
}
test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
-constraints {unixOnly testthread} \
-body {
update
set f1 [open [makeFile "" foo] w]
set f2 [open [makeFile "" foo2] w]
fileevent $f1 writable {set x 1}
fileevent $f2 writable {set y 1}
vwait x
close $f1
vwait y
close $f2
testthread create "testthread send [testthread id] {set x ok}"
vwait x
threadReap
set x
} \
-result {ok} \
-cleanup {
catch { close $f1 }
catch { close $f2 }
catch { removeFile foo }
catch { removeFile foo2 }
}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/utf.test.
1 2 3 4 5 6 7 8 9 10 | # This file contains a collection of tests for tclUtf.c # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
# This file contains a collection of tests for tclUtf.c
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: utf.test,v 1.8.14.5 2005/09/07 14:35:56 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} {
set x \x01
} [bytestring "\x01"]
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\x00"
} [bytestring "\xc0\x80"]
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} {
set x "\xe0"
} [bytestring "\xc3\xa0"]
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} {
set x "\u4e4e"
} [bytestring "\xe4\xb9\x8e"]
test utf-1.5 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
string length [format %c -1]
} 1
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} {3}
test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} {
string length [bytestring "\x82\x83\x84"]
} {3}
|
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} {
string length [bytestring "\xF4\xA2\xA2\xA2"]
} {4}
test utf-3.1 {Tcl_UtfCharComplete} {
} {}
| > | | | | | | > > > > > > > > > > > > > > > | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
test utf-2.8 {Tcl_UtfToUniChar: longer UTF sequences not supported} {
string length [bytestring "\xF4\xA2\xA2\xA2"]
} {4}
test utf-3.1 {Tcl_UtfCharComplete} {
} {}
testConstraint testnumutfchars [llength [info commands testnumutfchars]]
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} {0}
test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars {
testnumutfchars [bytestring "\xC2\xA2"]
} {1}
test utf-4.3 {Tcl_NumUtfChars: long string} testnumutfchars {
testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"]
} {7}
test utf-4.4 {Tcl_NumUtfChars: #u0000} testnumutfchars {
testnumutfchars [bytestring "\xC0\x80"]
} {1}
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
testnumutfchars "" 1
} {0}
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} testnumutfchars {
testnumutfchars [bytestring "\xC2\xA2"] 1
} {1}
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} testnumutfchars {
testnumutfchars [bytestring "abc\xC2\xA2\xe4\xb9\x8e\uA2\u4e4e"] 1
} {7}
test utf-4.8 {Tcl_NumUtfChars: #u0000, calc len} testnumutfchars {
testnumutfchars [bytestring "\xC0\x80"] 1
} {1}
test utf-5.1 {Tcl_UtfFindFirsts} {
} {}
test utf-6.1 {Tcl_UtfNext} {
} {}
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
string is digit \u1040
} {1}
test utf-24.2 {unicode digit char in regc_locale.c} {
# this returns 1 with Unicode 3 compliance
list [regexp {^[[:digit:]]+$} \u1040] [regexp {^\d+$} \u1040]
} {1 1}
| | | > > > > > > > > | > | > > | | | | | | | | | | | | | > > > > > > > > > > | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
string is digit \u1040
} {1}
test utf-24.2 {unicode digit char in regc_locale.c} {
# this returns 1 with Unicode 3 compliance
list [regexp {^[[:digit:]]+$} \u1040] [regexp {^\d+$} \u1040]
} {1 1}
test utf-24.3 {TclUniCharIsSpace} {
# this returns 1 with Unicode 3 compliance
string is space \u1680
} {1}
test utf-24.4 {unicode space char in regc_locale.c} {
# this returns 1 with Unicode 3 compliance
list [regexp {^[[:space:]]+$} \u1680] [regexp {^\s+$} \u1680]
} {1 1}
testConstraint teststringobj [llength [info commands teststringobj]]
test utf-25.1 {Tcl_UniCharNcasecmp} teststringobj {
testobj freeallvars
teststringobj set 1 a
teststringobj set 2 b
teststringobj getunicode 1
teststringobj getunicode 2
string compare -nocase [teststringobj get 1] [teststringobj get 2]
} -1
test utf-25.2 {Tcl_UniCharNcasecmp} teststringobj {
testobj freeallvars
teststringobj set 1 b
teststringobj set 2 a
teststringobj getunicode 1
teststringobj getunicode 2
string compare -nocase [teststringobj get 1] [teststringobj get 2]
} 1
test utf-25.3 {Tcl_UniCharNcasecmp} teststringobj {
testobj freeallvars
teststringobj set 1 B
teststringobj set 2 a
teststringobj getunicode 1
teststringobj getunicode 2
string compare -nocase [teststringobj get 1] [teststringobj get 2]
} 1
test utf-25.4 {Tcl_UniCharNcasecmp} teststringobj {
testobj freeallvars
teststringobj set 1 aBcB
teststringobj set 2 abca
teststringobj getunicode 1
teststringobj getunicode 2
string compare -nocase [teststringobj get 1] [teststringobj get 2]
} 1
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/util.test.
1 2 3 4 5 6 7 8 9 | # This file is a Tcl script to test the code in the file tclUtil.c. # This file is organized in the standard fashion for Tcl tests. # # Copyright (c) 1995-1998 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
# This file is a Tcl script to test the code in the file tclUtil.c.
# This file is organized in the standard fashion for Tcl tests.
#
# Copyright (c) 1995-1998 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: util.test,v 1.10.4.4 2005/10/28 03:26:33 mdejong Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test util-1.1 {TclFindElement procedure - binary element in middle of list} {
lindex {0 foo\x00help 1} 1
} "foo\x00help"
test util-1.2 {TclFindElement procedure - binary element at end of list} {
lindex {0 foo\x00help} 1
} "foo\x00help"
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
list [catch {set tcl_precision abc} msg] $msg $tcl_precision
} {1 {can't set "tcl_precision": improper value for precision} 12}
set tcl_precision 12
# This test always succeeded in the C locale anyway...
test util-8.1 {TclNeedSpace - correct UTF8 handling} {
interp create \u5420
interp create [list \u5420 foo]
interp alias {} fooset [list \u5420 foo] set
set result [interp target {} fooset]
interp delete \u5420
set result
} "\u5420 foo"
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 |
list [catch {set tcl_precision abc} msg] $msg $tcl_precision
} {1 {can't set "tcl_precision": improper value for precision} 12}
set tcl_precision 12
# This test always succeeded in the C locale anyway...
test util-8.1 {TclNeedSpace - correct UTF8 handling} {
# Bug 411825
# Note that this test relies on the fact that
# [interp target] calls on Tcl_AppendElement()
# which calls on TclNeedSpace(). If [interp target]
# is ever updated, this test will no longer test
# TclNeedSpace.
interp create \u5420
interp create [list \u5420 foo]
interp alias {} fooset [list \u5420 foo] set
set result [interp target {} fooset]
interp delete \u5420
set result
} "\u5420 foo"
tcltest::testConstraint testdstring [expr {[info commands testdstring] != {}}]
test util-8.2 {TclNeedSpace - correct UTF8 handling} testdstring {
# Bug 411825
# This tests the same bug as the previous test, but
# should be more future-proof, as the DString
# operations will likely continue to call TclNeedSpace
testdstring free
testdstring append \u5420 -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.3 {TclNeedSpace - correct UTF8 handling} testdstring {
# Bug 411825 - new variant reported by Dossy Shiobara
testdstring free
testdstring append \u00A0 -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.4 {TclNeedSpace - correct UTF8 handling} testdstring {
# Another bug uncovered while fixing 411825
testdstring free
testdstring append {\ } -1
testdstring append \{ -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.5 {TclNeedSpace - correct UTF8 handling} testdstring {
# Note that in this test TclNeedSpace actually gets it wrong,
# claiming we need a space when we really do not. Extra space
# between list elements is harmless though, and better to have
# extra space in really weird string reps of lists, than to
# invest the effort required to make TclNeedSpace foolproof.
testdstring free
testdstring append {\\ } -1
testdstring element foo
list [llength [testdstring get]] [string length [testdstring get]]
} {2 7}
test util-8.6 {TclNeedSpace - correct UTF8 handling} testdstring {
# Another example of TclNeedSpace harmlessly getting it wrong.
testdstring free
testdstring append {\\ } -1
testdstring append \{ -1
testdstring element foo
testdstring append \} -1
list [llength [testdstring get]] [string length [testdstring get]]
} {2 9}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/var.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: var.test,v 1.20.2.4 2007/03/13 15:59:53 dgp Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.2
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
set xxxxx
} {hello}
test var-3.9 {MakeUpvar, my var has invalid ns name} {
catch {unset aaaaa}
set aaaaa 789789
list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}}
if {[info commands testgetvarfullname] != {}} {
test var-4.1 {Tcl_GetVariableName, global variable} {
catch {unset a}
set a 123
testgetvarfullname a global
} ::a
| > > > > > > > > > > | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
set xxxxx
} {hello}
test var-3.9 {MakeUpvar, my var has invalid ns name} {
catch {unset aaaaa}
set aaaaa 789789
list [catch {upvar #0 aaaaa test_ns_fred::lnk} msg] $msg
} {1 {can't create "test_ns_fred::lnk": parent namespace doesn't exist}}
test var-3.10 {MakeUpvar, } {
namespace eval {} {
set bar 0
namespace eval foo upvar bar bar
set foo::bar 1
catch {list $bar $foo::bar} msg
unset ::aaaaa
set msg
}
} {1 1}
if {[info commands testgetvarfullname] != {}} {
test var-4.1 {Tcl_GetVariableName, global variable} {
catch {unset a}
set a 123
testgetvarfullname a global
} ::a
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
}
set x "If you see this, it worked"
} "If you see this, it worked"
test var-14.1 {array names syntax} -body {
array names foo bar baz snafu
} -returnCodes 1 -match glob -result *
catch {namespace delete ns}
catch {unset arr}
catch {unset v}
catch {rename p ""}
catch {namespace delete test_ns_var}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
}
set x "If you see this, it worked"
} "If you see this, it worked"
test var-14.1 {array names syntax} -body {
array names foo bar baz snafu
} -returnCodes 1 -match glob -result *
test var-15.1 {segfault in [unset], [Bug 735335]} {
proc A { name } {
upvar $name var
set var $name
}
#
# Note that the variable name has to be
# unused previously for the segfault to
# be triggered.
#
namespace eval test A useSomeUnlikelyNameHere
namespace eval test unset useSomeUnlikelyNameHere
} {}
test var-16.1 {CallVarTraces: save/restore interp error state: 1038021} {
trace add variable errorCode write { ;#}
catch {error foo bar baz}
trace remove variable errorCode write { ;#}
set errorInfo
} bar
test var-17.1 {TclArraySet [Bug 1669489]} -setup {
unset -nocomplain ::a
} -body {
namespace eval :: {
set elements {1 2 3 4}
trace add variable a write {string length $elements ;#}
array set a $elements
}
} -cleanup {
unset -nocomplain ::a ::elements
} -result {}
catch {namespace delete ns}
catch {unset arr}
catch {unset v}
catch {rename p ""}
catch {namespace delete test_ns_var}
|
| ︙ | ︙ |
Changes to tests/winDde.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file tests the tclWinDde.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# This file tests the tclWinDde.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winDde.test,v 1.13.2.2 2005/06/21 22:59:03 patthoyts Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {$tcl_platform(platform) == "windows"} {
|
| ︙ | ︙ | |||
48 49 50 51 52 53 54 55 56 |
puts "Unable to find the dde package. Skipping dde tests."
::tcltest::cleanupTests
return
}
}
puts $f [list dde servername $ddeServerName]
puts $f {
puts ready
vwait done
| > > | > > | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
puts "Unable to find the dde package. Skipping dde tests."
::tcltest::cleanupTests
return
}
}
puts $f [list dde servername $ddeServerName]
puts $f {
after 200 {set ready 1}
vwait ready
puts ready
vwait done
after 200 {set final 1}
vwait final
exit
}
close $f
set f [open |[list [interpreter] $::scriptName] r]
fconfigure $f -buffering line -blocking 1
gets $f
return $f
}
test winDde-1.1 {Settings the server's topic name} {pcOnly} {
list [dde servername foobar] [dde servername] [dde servername self]
} {foobar foobar self}
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
test winDde-3.5 {DDE request locally} {pcOnly} {
set a ""
dde execute TclEval self {set a "foo"}
dde request -binary TclEval self a
} "foo\x00"
test winDde-4.1 {DDE execute remotely} {stdio pcOnly} {
| > | | | | < | | > > | | | > | < | | > > | | | | | < | > | > | | | | < | > | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
test winDde-3.5 {DDE request locally} {pcOnly} {
set a ""
dde execute TclEval self {set a "foo"}
dde request -binary TclEval self a
} "foo\x00"
test winDde-4.1 {DDE execute remotely} {stdio pcOnly} {
list [catch {
set a ""
set child [createChildProcess child]
dde execute TclEval child {set a "foo"}
dde execute TclEval child {set done 1}
set a
} err] $err
} [list 0 ""]
test winDde-4.2 {DDE execute remotely} {stdio pcOnly} {
list [catch {
set a ""
set child [createChildProcess child]
dde execute -async TclEval child {set a "foo"}
after 400 {set ::_dde_forever 1} ; vwait ::_dde_forever; #update
dde execute TclEval child {set done 1}
set a
} err] $err
} [list 0 ""]
test winDde-4.3 {DDE request locally} {stdio pcOnly} {
list [catch {
set a ""
set child [createChildProcess child]
dde execute TclEval child {set a "foo"}
set a [dde request TclEval child a]
dde execute TclEval child {set done 1}
set a
} err] $err
} [list 0 foo]
test winDde-4.4 {DDE eval locally} {stdio pcOnly} {
list [catch {
set a ""
set child [createChildProcess child]
set a [dde eval child set a "foo"]
dde execute TclEval child {set done 1}
set a
} err] $err
} [list 0 foo]
test winDde-5.1 {check for bad arguments} {pcOnly} {
catch {dde execute "" "" "" ""} result
set result
} {wrong # args: should be "dde execute ?-async? serviceName topicName value"}
test winDde-5.2 {check for bad arguments} {pcOnly} {
|
| ︙ | ︙ |
Changes to tests/winFCmd.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclWinFCmd.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1996-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclWinFCmd.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1996-1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFCmd.test,v 1.20.2.9 2006/03/19 22:47:30 vincentdarley Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
set ::tcltest::testConstraints(cdrom) 0
set ::tcltest::testConstraints(exdev) 0
# find a CD-ROM so we can test read-only filesystems.
set cdrom {}
| | | < | < < < < < < < < | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
set ::tcltest::testConstraints(cdrom) 0
set ::tcltest::testConstraints(exdev) 0
# find a CD-ROM so we can test read-only filesystems.
set cdrom {}
if { [info commands ::testvolumetype] ne {} } {
foreach p {d e f g h i j k l m n o p q r s t u v w x y z} {
if { ! [catch { testvolumetype ${p}: } result] && $result eq {CDFS} } {
set cdrom ${p}:
}
}
}
proc findfile {dir} {
foreach p [glob $dir/*] {
if {[file type $p] == "file"} {
return $p
|
| ︙ | ︙ | |||
594 595 596 597 598 599 600 |
} {0}
test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {pcOnly 95} {
cleanup
list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {pcOnly nt} {
cleanup
| | > > > > > | | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 |
} {0}
test winFCmd-6.10 {TclpRemoveDirectory: attr == -1} {pcOnly 95} {
cleanup
list [catch {testfile rmdir nul} msg] $msg
} {1 {nul EACCES}}
test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {pcOnly nt} {
cleanup
set res [list [catch {testfile rmdir /} msg] $msg]
# WinXP returns EEXIST, WinNT seems to return EACCES. No policy
# decision has been made as to which is correct.
regsub {E(ACCES|EXIST)} $res "EACCES or EEXIST" res
# Don't mind which drive we're on
regsub {[A-Z]:} $res ""
} {1 {/ EACCES or EEXIST}}
test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {pcOnly 95} {
cleanup
createfile tf1
list [catch {testfile rmdir tf1} msg] $msg
} {1 {tf1 ENOTDIR}}
test winFCmd-6.13 {TclpRemoveDirectory: write-protected} {pcOnly} {
cleanup
|
| ︙ | ︙ | |||
688 689 690 691 692 693 694 |
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
{pcOnly} {
# can't make it happen
} {}
test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {pcOnly} {
cleanup
file mkdir td1
| < > | | 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 |
test winFCmd-7.10 {TraverseWinTree: can't read directory: handle == INVALID} \
{pcOnly} {
# can't make it happen
} {}
test winFCmd-7.11 {TraverseWinTree: call TraversalCopy: DOTREE_PRED} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testchmod 000 td1
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
} {1 1}
test winFCmd-7.12 {TraverseWinTree: call TraversalDelete: DOTREE_PRED} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile rmdir -force td1
file exists td1
} {0}
|
| ︙ | ︙ | |||
744 745 746 747 748 749 750 |
createfile td1/tf4
testfile cpdir td1 td2
lsort [glob td2/*]
} {td2/td2 td2/tf1 td2/tf2 td2/tf3 td2/tf4}
test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} {pcOnly} {
cleanup
file mkdir td1
| < > | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 |
createfile td1/tf4
testfile cpdir td1 td2
lsort [glob td2/*]
} {td2/td2 td2/tf1 td2/tf2 td2/tf3 td2/tf4}
test winFCmd-7.19 {TraverseWinTree: call TraversalCopy: DOTREE_POSTD} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testchmod 000 td1
testfile cpdir td1 td2
list [file exists td2] [file writable td2]
} {1 1}
test winFCmd-7.20 {TraverseWinTree: call TraversalDelete: DOTREE_POSTD} \
{pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile rmdir -force td1
file exists td1
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 971 972 973 974 975 976 977 |
test winFCmd-15.10 {SetWinFileAttributes - failing} {pcOnly cdrom} {
cleanup
catch {file attributes $cdfile -archive 1}
} {1}
test winFCmd-16.1 {Windows file normalization} {pcOnly} {
list [file normalize c:/] [file normalize C:/]
} {C:/ C:/}
# This block of code used to occur after the "return" call, so I'm
# commenting it out and assuming that this code is still under construction.
#foreach source {tef ted tnf tnd "" nul com1} {
# foreach chmodsrc {000 755} {
# foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" {
# foreach chmoddst {000 755} {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 |
test winFCmd-15.10 {SetWinFileAttributes - failing} {pcOnly cdrom} {
cleanup
catch {file attributes $cdfile -archive 1}
} {1}
test winFCmd-16.1 {Windows file normalization} {pcOnly} {
list [file normalize c:/] [file normalize C:/]
} {C:/ C:/}
test winFCmd-16.2 {Windows file normalization} {pcOnly} {
close [open td1... w]
set res [file tail [file normalize td1]]
file delete td1...
set res
} {td1}
set pwd [pwd]
set d [string index $pwd 0]
test winFCmd-16.3 {Windows file normalization} {pcOnly} {
file norm ${d}:foo
} [file join $pwd foo]
test winFCmd-16.4 {Windows file normalization} {pcOnly} {
file norm [string tolower ${d}]:foo
} [file join $pwd foo]
test winFCmd-16.5 {Windows file normalization} {pcOnly} {
file norm ${d}:foo/bar
} [file join $pwd foo/bar]
test winFCmd-16.6 {Windows file normalization} {pcOnly} {
file norm ${d}:foo\\bar
} [file join $pwd foo/bar]
test winFCmd-16.7 {Windows file normalization} {pcOnly} {
file norm /bar
} "${d}:/bar"
test winFCmd-16.8 {Windows file normalization} {pcOnly} {
file norm ///bar
} "${d}:/bar"
test winFCmd-16.9 {Windows file normalization} {pcOnly} {
file norm /bar/foo
} "${d}:/bar/foo"
if {$d eq "C"} { set dd "D" } else { set dd "C" }
test winFCmd-16.10 {Windows file normalization} {pcOnly} {
file norm ${dd}:foo
} "${dd}:/foo"
test winFCmd-16.11 {Windows file normalization} {pcOnly cdrom} {
cd ${d}:
cd $cdrom
cd ${d}:
cd $cdrom
# Must not crash
set result "no crash"
} {no crash}
test winFCmd-16.12 {Windows file normalization} {pcOnly} {
set oldhome ""
catch {set oldhome $::env(HOME)}
set ::env(HOME) ${d}:
cd
set result [pwd]; # <- Must not crash
set ::env(HOME) $oldhome
set result
} ${d}:/
cd $pwd
unset d dd pwd
test winFCmd-18.1 {Windows reserved path names} -constraints win -body {
file pathtype com1
} -result "absolute"
test winFCmd-18.1.2 {Windows reserved path names} -constraints win -body {
file pathtype com4
} -result "absolute"
test winFCmd-18.1.3 {Windows reserved path names} -constraints win -body {
file pathtype com5
} -result "relative"
test winFCmd-18.1.4 {Windows reserved path names} -constraints win -body {
file pathtype lpt3
} -result "absolute"
test winFCmd-18.1.5 {Windows reserved path names} -constraints win -body {
file pathtype lpt4
} -result "relative"
test winFCmd-18.1.6 {Windows reserved path names} -constraints win -body {
file pathtype nul
} -result "absolute"
test winFCmd-18.1.7 {Windows reserved path names} -constraints win -body {
file pathtype null
} -result "relative"
test winFCmd-18.2 {Windows reserved path names} -constraints win -body {
file pathtype com1:
} -result "absolute"
test winFCmd-18.3 {Windows reserved path names} -constraints win -body {
file pathtype COM1
} -result "absolute"
test winFCmd-18.4 {Windows reserved path names} -constraints win -body {
file pathtype CoM1:
} -result "absolute"
test winFCmd-18.5 {Windows reserved path names} -constraints win -body {
file normalize com1:
} -result COM1
test winFCmd-18.6 {Windows reserved path names} -constraints win -body {
file normalize COM1:
} -result COM1
test winFCmd-18.7 {Windows reserved path names} -constraints win -body {
file normalize cOm1
} -result COM1
test winFCmd-18.8 {Windows reserved path names} -constraints win -body {
file normalize cOm1:
} -result COM1
# This block of code used to occur after the "return" call, so I'm
# commenting it out and assuming that this code is still under construction.
#foreach source {tef ted tnf tnd "" nul com1} {
# foreach chmodsrc {000 755} {
# foreach dest "tfn tfe tdn tdempty tdfull td1/td2 $p $p/td1 {} nul" {
# foreach chmoddst {000 755} {
|
| ︙ | ︙ |
Changes to tests/winFile.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclWinFile.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
# This file tests the tclWinFile.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winFile.test,v 1.9.2.1 2003/04/14 15:45:58 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test winFile-1.1 {TclpGetUserHome} {pcOnly} {
list [catch {glob ~nosuchuser} msg] $msg
} {1 {user "nosuchuser" doesn't exist}}
test winFile-1.2 {TclpGetUserHome} {pcOnly nt nonPortable} {
# The administrator account should always exist.
catch {glob ~administrator}
} {0}
test winFile-1.3 {TclpGetUserHome} {pcOnly 95} {
# Find some user in system.ini and then see if they have a home.
set f [open $::env(windir)/system.ini]
set x 0
while {![eof $f]} {
set line [gets $f]
if {$line == "\[Password Lists]"} {
gets $f
set name [lindex [split [gets $f] =] 0]
if {$name != ""} {
set x [catch {glob ~$name}]
break
}
}
}
close $f
set x
} {0}
test winFile-1.4 {TclpGetUserHome} {pcOnly nt nonPortable} {
catch {glob ~stanton@workgroup}
} {0}
test winFile-2.1 {TclpMatchFiles: case sensitivity} {pcOnly} {
makeFile {} GlobCapS
set result [list [glob -nocomplain GlobC*] [glob -nocomplain globc*]]
removeFile GlobCapS
|
| ︙ | ︙ |
Changes to tests/winPipe.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # # Copyright (c) 1996 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: winPipe.test,v 1.22.2.4 2005/04/20 00:14:54 hobbs Exp $ package require tcltest namespace import -force ::tcltest::* unset -nocomplain path testConstraint exec [llength [info commands exec]] set bindir [file join [pwd] [file dirname [info nameofexecutable]]] set cat32 [file join $bindir cat32.exe] set ::tcltest::testConstraints(cat32) [file exists $cat32] |
| ︙ | ︙ | |||
290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
vwait x
puts $f foobar
flush $f
vwait x
lappend x [read $f]
after 100 { lappend x timeout }
vwait x
lappend x [catch {close $f} msg] $msg
} {writable timeout readable {foobar
} timeout 1 stderr32}
test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \
{pcOnly exec cat32} {
set f [open "|[list $cat32]" r+]
fconfigure $f -blocking 0
| > | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
vwait x
puts $f foobar
flush $f
vwait x
lappend x [read $f]
after 100 { lappend x timeout }
vwait x
fconfigure $f -blocking 1
lappend x [catch {close $f} msg] $msg
} {writable timeout readable {foobar
} timeout 1 stderr32}
test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \
{pcOnly exec cat32} {
set f [open "|[list $cat32]" r+]
fconfigure $f -blocking 0
|
| ︙ | ︙ | |||
311 312 313 314 315 316 317 318 319 |
lappend x [catch {close $f} msg] $msg
} {writable timeout 0 {}}
set path(echoArgs.tcl) [makeFile {
puts "[list $argv0 $argv]"
} echoArgs.tcl]
test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo "" bar
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 |
lappend x [catch {close $f} msg] $msg
} {writable timeout 0 {}}
set path(echoArgs.tcl) [makeFile {
puts "[list $argv0 $argv]"
} echoArgs.tcl]
### validate the raw output of BuildCommandLine().
###
test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo "" bar
} {foo "" bar}
test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {} bar
} {foo "" bar}
test winpipe-7.3 {BuildCommandLine: dbl quote quoting #1} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {"} bar
} {foo \" bar}
test winpipe-7.4 {BuildCommandLine: dbl quote quoting #2} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {""} bar
} {foo \"\" bar}
test winpipe-7.5 {BuildCommandLine: dbl quote quoting #3} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {" } bar
} {foo "\" " bar}
test winpipe-7.6 {BuildCommandLine: dbl quote quoting #4} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {a="b"} bar
} {foo a=\"b\" bar}
test winpipe-7.7 {BuildCommandLine: dbl quote quoting #5} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo {a = "b"} bar
} {foo "a = \"b\"" bar}
test winpipe-7.8 {BuildCommandLine: dbl quote quoting #6} {pcOnly exec} {
exec $env(COMSPEC) /c echo {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}
} {\"hello\" \"\"hello\"\" \"\"\"hello\"\"\" \"\\\"hello\\\"\" "he llo" "he \" llo"}
test winpipe-7.9 {BuildCommandLine: N backslashes followed a quote rule #1} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\ bar
} {foo \ bar}
test winpipe-7.10 {BuildCommandLine: N backslashes followed a quote rule #2} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\\ bar
} {foo \\ bar}
test winpipe-7.11 {BuildCommandLine: N backslashes followed a quote rule #3} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\ bar
} {foo "\ \\" bar}
test winpipe-7.12 {BuildCommandLine: N backslashes followed a quote rule #4} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\\ bar
} {foo "\ \\\\" bar}
test winpipe-7.13 {BuildCommandLine: N backslashes followed a quote rule #5} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\\\\ bar
} {foo "\ \\\\\\" bar}
test winpipe-7.14 {BuildCommandLine: N backslashes followed a quote rule #6} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\" bar
} {foo "\ \\\"" bar}
test winpipe-7.15 {BuildCommandLine: N backslashes followed a quote rule #7} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\\\" bar
} {foo "\ \\\\\"" bar}
test winpipe-7.16 {BuildCommandLine: N backslashes followed a quote rule #8} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \\\ \\\\\\\" bar
} {foo "\ \\\\\\\"" bar}
test winpipe-7.17 {BuildCommandLine: special chars #4} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \{ bar
} "foo \{ bar"
test winpipe-7.18 {BuildCommandLine: special chars #5} {pcOnly exec} {
exec $env(COMSPEC) /c echo foo \} bar
} "foo \} bar"
### validate the pass-thru from BuildCommandLine() to the crt's parse_cmdline().
###
test winpipe-8.1 {BuildCommandLine/parse_cmdline pass-thru: null arguments} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo "" bar
} [list $path(echoArgs.tcl) [list foo {} bar]]
test winpipe-8.2 {BuildCommandLine/parse_cmdline pass-thru: null arguments} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {} bar
} [list $path(echoArgs.tcl) [list foo {} bar]]
test winpipe-8.3 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #1} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {"} bar
} [list $path(echoArgs.tcl) [list foo {"} bar]]
test winpipe-8.4 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #2} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {""} bar
} [list $path(echoArgs.tcl) [list foo {""} bar]]
test winpipe-8.5 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #3} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {" } bar
} [list $path(echoArgs.tcl) [list foo {" } bar]]
test winpipe-8.6 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #4} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {a="b"} bar
} [list $path(echoArgs.tcl) [list foo {a="b"} bar]]
test winpipe-8.7 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #5} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo {a = "b"} bar
} [list $path(echoArgs.tcl) [list foo {a = "b"} bar]]
test winpipe-8.8 {BuildCommandLine/parse_cmdline pass-thru: dbl quote quoting #6} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}
} [list $path(echoArgs.tcl) [list {"hello"} {""hello""} {"""hello"""} {"\"hello\""} {he llo} {he " llo}]]
test winpipe-8.9 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #1} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\ bar
} [list $path(echoArgs.tcl) [list foo \\ bar]]
test winpipe-8.10 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #2} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\\ bar
} [list $path(echoArgs.tcl) [list foo \\\\ bar]]
test winpipe-8.11 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #3} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\ bar
} [list $path(echoArgs.tcl) [list foo \\\ \\ bar]]
test winpipe-8.12 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #4} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\ bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\\ bar]]
test winpipe-8.13 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #5} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\\ bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\\\\ bar]]
test winpipe-8.14 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #6} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\" bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\" bar]]
test winpipe-8.15 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #7} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\" bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\\\" bar]]
test winpipe-8.16 {BuildCommandLine/parse_cmdline pass-thru: N backslashes followed a quote rule #8} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \\\ \\\\\\\" bar
} [list $path(echoArgs.tcl) [list foo \\\ \\\\\\\" bar]]
test winpipe-8.17 {BuildCommandLine/parse_cmdline pass-thru: special chars #1} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \{ bar
} [list $path(echoArgs.tcl) [list foo \{ bar]]
test winpipe-8.18 {BuildCommandLine/parse_cmdline pass-thru: special chars #2} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \} bar
} [list $path(echoArgs.tcl) [list foo \} bar]]
test winpipe-8.19 {ensure parse_cmdline isn't doing wildcard replacement} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo * makefile.?c bar
} [list $path(echoArgs.tcl) [list foo * makefile.?c bar]]
# restore old values for env(TMP) and env(TEMP)
if {[catch {set env(TMP) $env_tmp}]} {
unset env(TMP)
}
if {[catch {set env(TEMP) $env_temp}]} {
|
| ︙ | ︙ |
Changes to tests/winTime.test.
1 2 3 4 5 6 7 8 9 10 11 12 | # This file tests the tclWinTime.c file. # # This file contains a collection of tests for one or more of the Tcl # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# This file tests the tclWinTime.c file.
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: winTime.test,v 1.8.2.1 2003/04/12 20:11:34 kennykb Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint testwinclock [llength [info commands testwinclock]]
|
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
set ::env(TZ) PST8
set result [clock format 1 -format %Y]
unset ::env(TZ)
set result
} {1969}
# Next test tries to make sure that the Tcl clock stays in step
| | | > | | | | > < < < < < < < < < < < < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
set ::env(TZ) PST8
set result [clock format 1 -format %Y]
unset ::env(TZ)
set result
} {1969}
# Next test tries to make sure that the Tcl clock stays in step
# with the Windows clock. 30 sec really isn't enough,
# but how much time does a tester have patience for?
test winTime-2.1 {Synchronization of Tcl and Windows clocks} {testwinclock} {
# May fail due to OS/hardware discrepancies. See:
# http://support.microsoft.com/default.aspx?scid=kb;en-us;274323
set failed {}
set ok 1
foreach start_sec [testwinclock] break
while { 1 } {
foreach { sys_sec sys_usec tcl_sec tcl_usec } [testwinclock] break
set diff [expr { $tcl_sec - $sys_sec
+ 1.0e-6 * ( $tcl_usec - $sys_usec ) }]
if { abs($diff) > 0.06 } {
set failed "Tcl clock differs from system clock by $diff sec"
break
} else {
testwinsleep 1
}
if { $sys_sec - $start_sec >= 30 } break
}
set failed
} {}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tools/encoding/txt2enc.c.
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | case 's': symbol = 1; break; case 'm': fixmissing = 0; break; | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
case 's':
symbol = 1;
break;
case 'm':
fixmissing = 0;
break;
default:
goto usage;
}
}
if ((optind < argc - 1) || (optind >= argc)) {
usage:
|
| ︙ | ︙ | |||
170 171 172 173 174 175 176 |
rest++;
}
str = rest;
}
if (enc < 32 || uni < 32) {
continue;
}
| | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
rest++;
}
str = rest;
}
if (enc < 32 || uni < 32) {
continue;
}
hi = enc >> 8;
lo = enc & 0xff;
if (toUnicode[hi] == NULL) {
toUnicode[hi] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[hi], 0, 256 * sizeof(Rune));
}
toUnicode[hi][lo] = uni;
}
fclose(fp);
dot = strrchr(argv[argc - 1], '.');
if (dot != NULL) {
*dot = '\0';
}
if (type == -1) {
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
used = 0;
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
used++;
}
}
printf("%c\n%04X %d %d\n", "SDM"[type], fallbackChar, symbol, used);
| | > > > > > > > | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 |
used = 0;
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
used++;
}
}
printf("%c\n%04X %d %d\n", "SDM"[type], fallbackChar, symbol, used);
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
printf("%02X\n", hi);
for (lo = 0; lo < 256; lo++) {
printf("%04X", toUnicode[hi][lo]);
if ((lo & 0x0f) == 0x0f) {
putchar('\n');
}
}
}
}
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
free(toUnicode[hi]);
toUnicode[hi] = NULL;
}
}
return 0;
}
|
Changes to tools/index.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # index.tcl -- # # This file defines procedures that are used during the first pass of # the man page conversion. It is used to extract information used to # generate a table of contents and a keyword list. # # Copyright (c) 1996 by Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # index.tcl -- # # This file defines procedures that are used during the first pass of # the man page conversion. It is used to extract information used to # generate a table of contents and a keyword list. # # Copyright (c) 1996 by Sun Microsystems, Inc. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # RCS: @(#) $Id: index.tcl,v 1.3.40.1 2003/06/04 23:41:15 mistachkin Exp $ # # Global variables used by these scripts: # # state - state variable that controls action of text proc. # # topics - array indexed by (package,section,topic) with value |
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
foreach i [array names topics "${pkg},*"] {
regsub {^.*,(.*),.*$} $i {\1} i
set temp($i) {}
}
lsort [array names temp]
}
| | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
foreach i [array names topics "${pkg},*"] {
regsub {^.*,(.*),.*$} $i {\1} i
set temp($i) {}
}
lsort [array names temp]
}
# getTopics --
#
# Generate a sorted list of topics in the specified section of the
# specified package from the topics array.
#
# Arguments:
# pkg - Name of package to search.
# sect - Name of section to search.
|
| ︙ | ︙ |
Changes to tools/man2help.tcl.
1 2 3 4 5 6 7 8 | # man2help.tcl -- # # This file defines procedures that work in conjunction with the # man2tcl program to generate a Windows help file from Tcl manual # entries. # # Copyright (c) 1996 by Sun Microsystems, Inc. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # man2help.tcl -- # # This file defines procedures that work in conjunction with the # man2tcl program to generate a Windows help file from Tcl manual # entries. # # Copyright (c) 1996 by Sun Microsystems, Inc. # # RCS: @(#) $Id: man2help.tcl,v 1.13.2.1 2003/06/04 23:41:15 mistachkin Exp $ # # # PASS 1 # set man2tclprog [file join [file dirname [info script]] man2tcl.exe] |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 |
doFile $f
}
set fd [open [file join [file dirname [info script]] $basename$version.cnt] w]
fconfigure $fd -translation crlf
puts $fd ":Base $basename$version.hlp"
foreach package [getPackages] {
foreach section [getSections $package] {
| > > > > | > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
doFile $f
}
set fd [open [file join [file dirname [info script]] $basename$version.cnt] w]
fconfigure $fd -translation crlf
puts $fd ":Base $basename$version.hlp"
foreach package [getPackages] {
foreach section [getSections $package] {
if {![info exists lastSection]} {
set lastSection {}
}
if {[string compare $lastSection $section]} {
puts $fd "1 $section"
}
set lastSection $section
set lastTopic {}
foreach topic [getTopics $package $section] {
if {[string compare $lastTopic $topic]} {
set id $topics($package,$section,$topic)
puts $fd "2 $topic=$id"
set lastTopic $topic
}
|
| ︙ | ︙ |
Changes to tools/man2tcl.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | * man2tcl ?fileName? * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > > > > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | * man2tcl ?fileName? * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: man2tcl.c,v 1.7.2.1 2003/12/09 15:32:20 dkf Exp $ */ static char sccsid[] = "@(#) man2tcl.c 1.3 95/08/12 17:34:08"; #include <stdio.h> #include <string.h> #include <ctype.h> #ifndef NO_ERRNO_H #include <errno.h> #endif /* * Imported things that aren't defined in header files: */ /* * Some <errno.h> define errno to be something complex and * thread-aware; in that case we definitely do not want to declare * errno ourselves! */ #ifndef errno extern int errno; #endif /* * Current line number, used for error messages. */ static int lineNumber; |
| ︙ | ︙ |
Changes to tools/tcl.wse.in.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | Japanese Font Size=10 Start Gradient=0 0 255 End Gradient=0 0 0 Windows Flags=00000000000000010010110000001000 Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | Japanese Font Size=10 Start Gradient=0 0 255 End Gradient=0 0 0 Windows Flags=00000000000000010010110000001000 Log Pathname=%MAINDIR%\INSTALL.LOG Message Font=MS Sans Serif Font Size=8 Disk Label=tcl8.4.16 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 Patch Memory=4000 Variable Name1=_SYS_ Variable Default1=C:\WINDOWS\SYSTEM Variable Flags1=00001000 |
| ︙ | ︙ | |||
1439 1440 1441 1442 1443 1444 1445 |
item: Install File
Source=${__TCLBASEDIR__}\library\opt\optparse.tcl
Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\optparse.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\http\pkgIndex.tcl
| | | | 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 |
item: Install File
Source=${__TCLBASEDIR__}\library\opt\optparse.tcl
Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\optparse.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\http\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\http2.5\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\http\http.tcl
Destination=%MAINDIR%\lib\tcl%VER%\http2.5\http.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TKBASEDIR__}\library\msgbox.tcl
Destination=%MAINDIR%\lib\tk%VER%\msgbox.tcl
Flags=0000000000000010
end
|
| ︙ | ︙ |
Changes to tools/tclmin.wse.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | item: Install File Source=n:\dist\tcl8.0\library\opt0.4\optparse.tcl Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\optparse.tcl Flags=0000000000000010 end item: Install File Source=n:\dist\tcl8.0\library\http\pkgIndex.tcl | | | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | item: Install File Source=n:\dist\tcl8.0\library\opt0.4\optparse.tcl Destination=%MAINDIR%\lib\tcl%VER%\opt0.4\optparse.tcl Flags=0000000000000010 end item: Install File Source=n:\dist\tcl8.0\library\http\pkgIndex.tcl Destination=%MAINDIR%\lib\tcl%VER%\http2.5\pkgIndex.tcl Flags=0000000000000010 end item: Install File Source=n:\dist\tcl8.0\library\http\http.tcl Destination=%MAINDIR%\lib\tcl%VER%\http2.5\http.tcl Flags=0000000000000010 end item: Install File Source=n:\dist\tcl8.0\library\safe.tcl Destination=%MAINDIR%\lib\tcl%VER%\safe.tcl Flags=0000000000000010 end |
| ︙ | ︙ |
Changes to tools/tcltk-man2html.tcl.
1 2 | #!/bin/sh # The next line is executed by /bin/sh, but not tcl \ | | | | 1 2 3 4 5 6 7 8 9 10 11 12 |
#!/bin/sh
# The next line is executed by /bin/sh, but not tcl \
exec tclsh8.4 "$0" ${1+"$@"}
package require Tcl 8.4
# Convert Ousterhout format man pages into highly crosslinked
# hypertext.
#
# Along the way detect many unmatched font changes and other odd
# things.
#
|
| ︙ | ︙ | |||
61 62 63 64 65 66 67 | # May 28, 1997 - added tcl8.0b1/tk8.0b1 to the list of distributions # - cleaned source for tclsh8.0 execution # - renamed output files for windoze installation # - added spaces to tables # Oct 24, 1997 - moved from 8.0b1 to 8.0 release # | | | | < | > | > > > > > > > > > > > > > > > > > > > > | | | < < < < | | | | > | > > | | | < < < < | | | | > | > | > > > > | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
# May 28, 1997 - added tcl8.0b1/tk8.0b1 to the list of distributions
# - cleaned source for tclsh8.0 execution
# - renamed output files for windoze installation
# - added spaces to tables
# Oct 24, 1997 - moved from 8.0b1 to 8.0 release
#
set Version "0.32"
proc parse_command_line {} {
global argv Version
# These variables determine where the man pages come from and where
# the converted pages go to.
global tcltkdir tkdir tcldir webdir build_tcl build_tk
# Set defaults based on original code.
set tcltkdir ../..
set tkdir {}
set tcldir {}
set webdir ../html
set build_tcl 0
set build_tk 0
# Default search version is a glob pattern
set useversion {{,[8-9].[0-9]{,.[0-9]{,[0-9]}}}}
# Handle arguments a la GNU:
# --version
# --useversion=<version>
# --help
# --srcdir=/path
# --htmldir=/path
foreach option $argv {
switch -glob -- $option {
--version {
puts "tcltk-man-html $Version"
exit 0
}
--help {
puts "usage: tcltk-man-html \[OPTION\] ...\n"
puts " --help print this help, then exit"
puts " --version print version number, then exit"
puts " --srcdir=DIR find tcl and tk source below DIR"
puts " --htmldir=DIR put generated HTML in DIR"
puts " --tcl build tcl help"
puts " --tk build tk help"
puts " --useversion version of tcl/tk to search for"
exit 0
}
--srcdir=* {
# length of "--srcdir=" is 9.
set tcltkdir [string range $option 9 end]
}
--htmldir=* {
# length of "--htmldir=" is 10
set webdir [string range $option 10 end]
}
--useversion=* {
# length of "--useversion=" is 13
set useversion [string range $option 13 end]
}
--tcl {
set build_tcl 1
}
--tk {
set build_tk 1
}
default {
puts stderr "tcltk-man-html: unrecognized option -- `$option'"
exit 1
}
}
}
if {!$build_tcl && !$build_tk} {set build_tcl 1; set build_tk 1}
if {$build_tcl} {
# Find Tcl.
set tcldir [lindex [lsort [glob -nocomplain -tails -type d \
-directory $tcltkdir tcl$useversion]] end]
if {$tcldir == ""} then {
puts stderr "tcltk-man-html: couldn't find Tcl below $tcltkdir"
exit 1
}
puts "using Tcl source directory $tcldir"
}
if {$build_tk} {
# Find Tk.
set tkdir [lindex [lsort [glob -nocomplain -tails -type d \
-directory $tcltkdir tk$useversion]] end]
if {$tkdir == ""} then {
puts stderr "tcltk-man-html: couldn't find Tk below $tcltkdir"
exit 1
}
puts "using Tk source directory $tkdir"
}
# the title for the man pages overall
global overall_title
set overall_title ""
if {$build_tcl} {append overall_title "[capitalize $tcldir]"}
if {$build_tcl && $build_tk} {append overall_title "/"}
if {$build_tk} {append overall_title "[capitalize $tkdir]"}
append overall_title " Manual"
}
proc capitalize {string} {
return [string toupper $string 0]
}
##
|
| ︙ | ︙ | |||
214 215 216 217 218 219 220 221 222 223 224 225 226 227 |
"\\\n" "\n" \
\" {"} \
{<} {<} \
{>} {>} \
{\(+-} {±} \
{\fP} {\fR} \
{\.} . \
] $text]
regsub -all {\\o'o\^'} $text {\ô} text; # o-circumflex in re_syntax.n
regsub -all {\\-\\\|\\-} $text -- text; # two hyphens
regsub -all -- {\\-\\\^\\-} $text -- text; # two hyphens
regsub -all {\\-} $text - text; # a hyphen
regsub -all "\\\\\n" $text "\\\\n" text; # backslashed newline
while {[string first "\\" $text] >= 0} {
| > | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
"\\\n" "\n" \
\" {"} \
{<} {<} \
{>} {>} \
{\(+-} {±} \
{\fP} {\fR} \
{\.} . \
{\(bu} {•} \
] $text]
regsub -all {\\o'o\^'} $text {\ô} text; # o-circumflex in re_syntax.n
regsub -all {\\-\\\|\\-} $text -- text; # two hyphens
regsub -all -- {\\-\\\^\\-} $text -- text; # two hyphens
regsub -all {\\-} $text - text; # a hyphen
regsub -all "\\\\\n" $text "\\\\n" text; # backslashed newline
while {[string first "\\" $text] >= 0} {
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
man-puts <P>$rest
return
}
if {[next-op-is .RE rest]} {
return
}
}
| | | | 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
man-puts <P>$rest
return
}
if {[next-op-is .RE rest]} {
return
}
}
man-puts <DL><DD>
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
switch -exact $code {
.RE {
break
}
.SH - .SS {
manerror "unbalanced .RS at section end"
backup-text 1
break
}
default {
output-directive $line
}
|
| ︙ | ︙ | |||
496 497 498 499 500 501 502 |
## process .IP lists which may be plain indents,
## numeric lists, or definition lists
##
proc output-IP-list {context code rest} {
global manual
if {![string length $rest]} {
# blank label, plain indent, no contents entry
| | | 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 |
## process .IP lists which may be plain indents,
## numeric lists, or definition lists
##
proc output-IP-list {context code rest} {
global manual
if {![string length $rest]} {
# blank label, plain indent, no contents entry
man-puts <DL><DD>
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
if {[string equal $code ".IP"] && [string equal $rest {}]} {
man-puts "<P>"
continue
|
| ︙ | ︙ | |||
518 519 520 521 522 523 524 |
} else {
man-puts $line
}
}
man-puts </DL>
} else {
# labelled list, make contents
| > | > > > | > > | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
} else {
man-puts $line
}
}
man-puts </DL>
} else {
# labelled list, make contents
if {
[string compare $context ".SH"] &&
[string compare $context ".SS"]
} then {
man-puts <P>
}
man-puts <DL>
lappend manual(section-toc) <DL>
backup-text 1
set accept_RE 0
set para {}
while {[more-text]} {
set line [next-text]
if {[is-a-directive $line]} {
split-directive $line code rest
switch -exact $code {
.IP {
if {$accept_RE} {
output-IP-list .IP $code $rest
continue
}
if {[string equal $manual(section) "ARGUMENTS"] || \
[regexp {^\[\d+\]$} $rest]} {
man-puts "$para<DT>$rest<DD>"
} elseif {[string equal {•} $rest]} {
man-puts "$para<DT><DD>$rest "
} else {
man-puts "$para<DT>[long-toc $rest]<DD>"
}
if {[string equal $manual(name):$manual(section) \
"selection:DESCRIPTION"]} {
if {[match-text .RE @rest .RS .RS]} {
man-puts <DT>[long-toc $rest]<DD>
}
}
|
| ︙ | ︙ | |||
574 575 576 577 578 579 580 |
} else {
output-directive $line
}
}
.PP {
if {[match-text @rest1 .br @rest2 .RS]} {
# yet another nroff kludge as above
| | > | 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 |
} else {
output-directive $line
}
}
.PP {
if {[match-text @rest1 .br @rest2 .RS]} {
# yet another nroff kludge as above
man-puts "$para<DT>[long-toc $rest1]"
man-puts "<DT>[long-toc $rest2]<DD>"
incr accept_RE 1
} elseif {[match-text @rest .RE]} {
# gad, this is getting ridiculous
if {!$accept_RE} {
man-puts "</DL><P>$rest<DL>"
backup-text 1
set para {}
break
} else {
man-puts "<P>$rest"
incr accept_RE -1
}
} elseif {$accept_RE} {
output-directive $line
|
| ︙ | ︙ | |||
609 610 611 612 613 614 615 616 |
backup-text 1
break
}
}
} else {
man-puts $line
}
}
| > | | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 |
backup-text 1
break
}
}
} else {
man-puts $line
}
set para <P>
}
man-puts "$para</DL>"
lappend manual(section-toc) </DL>
if {$accept_RE} {
manerror "missing .RE in output-IP-list"
}
}
}
##
|
| ︙ | ︙ | |||
662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
##
## nothing to reference
##
if {![info exists manual(name-$lref)]} {
foreach name {array file history info interp string trace
after clipboard grab image option pack place selection tk tkwait update winfo wm} {
if {[regexp "^$name \[a-z0-9]*\$" $lref] && \
[string compare $manual(tail) "$name.n"]} {
return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>"
}
}
if {[lsearch {stdin stdout stderr end} $lref] >= 0} {
# no good place to send these
# tcl tokens?
| > | 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 |
##
## nothing to reference
##
if {![info exists manual(name-$lref)]} {
foreach name {array file history info interp string trace
after clipboard grab image option pack place selection tk tkwait update winfo wm} {
if {[regexp "^$name \[a-z0-9]*\$" $lref] && \
[info exists manual(name-$name)] && \
[string compare $manual(tail) "$name.n"]} {
return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>"
}
}
if {[lsearch {stdin stdout stderr end} $lref] >= 0} {
# no good place to send these
# tcl tokens?
|
| ︙ | ︙ | |||
934 935 936 937 938 939 940 |
# process format directive
split-directive $line code rest
switch -exact $code {
.BS -
.BE {
# man-puts <HR>
}
| | > | > > > | 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 |
# process format directive
split-directive $line code rest
switch -exact $code {
.BS -
.BE {
# man-puts <HR>
}
.SH - .SS {
# drain any open lists
# announce the subject
set manual(section) $rest
# start our own stack of stuff
set manual($manual(name)-$manual(section)) {}
lappend manual(has-$manual(section)) $manual(name)
if {[string compare .SS $code]} {
man-puts "<H3>[long-toc $manual(section)]</H3>"
} else {
man-puts "<H4>[long-toc $manual(section)]</H4>"
}
# some sections can simply free wheel their way through the text
# some sections can be processed in their own loops
switch -exact $manual(section) {
NAME {
if {[lsearch {CrtImgType.3 CrtItemType.3 CrtPhImgFmt.3} $manual(tail)] >= 0} {
# these manual pages have two NAME sections
if {[info exists manual($manual(tail)-NAME)]} {
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 981 982 983 984 985 986 987 |
while {1} {
if {[next-op-is .nf rest]
|| [next-op-is .br rest]
|| [next-op-is .fi rest]} {
continue
}
if {[next-op-is .SH rest]
|| [next-op-is .BE rest]
|| [next-op-is .SO rest]} {
backup-text 1
break
}
if {[next-op-is .sp rest]} {
#man-puts <P>
| > | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 |
while {1} {
if {[next-op-is .nf rest]
|| [next-op-is .br rest]
|| [next-op-is .fi rest]} {
continue
}
if {[next-op-is .SH rest]
|| [next-op-is .SS rest]
|| [next-op-is .BE rest]
|| [next-op-is .SO rest]} {
backup-text 1
break
}
if {[next-op-is .sp rest]} {
#man-puts <P>
|
| ︙ | ︙ | |||
1002 1003 1004 1005 1006 1007 1008 |
}
}
lappend manual(section-toc) </DL>
return
}
{SEE ALSO} {
while {[more-text]} {
| | | 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 |
}
}
lappend manual(section-toc) </DL>
return
}
{SEE ALSO} {
while {[more-text]} {
if {[next-op-is .SH rest] || [next-op-is .SS rest]} {
backup-text 1
return
}
set more [next-text]
if {[is-a-directive $more]} {
manerror "$more"
backup-text 1
|
| ︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 |
}
man-puts [join $nmore {, }]
}
return
}
KEYWORDS {
while {[more-text]} {
| | | 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 |
}
man-puts [join $nmore {, }]
}
return
}
KEYWORDS {
while {[more-text]} {
if {[next-op-is .SH rest] || [next-op-is .SS rest]} {
backup-text 1
return
}
set more [next-text]
if {[is-a-directive $more]} {
manerror "$more"
backup-text 1
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 |
}
man-puts [join $keys {, }]
}
return
}
}
if {[next-op-is .IP rest]} {
| | | 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 |
}
man-puts [join $keys {, }]
}
return
}
}
if {[next-op-is .IP rest]} {
output-IP-list $code .IP $rest
return
}
if {[next-op-is .PP rest]} {
return
}
return
}
|
| ︙ | ︙ | |||
1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 |
{bind:MODIFIERS} -
{bind:EVENT TYPES} -
{bind:BINDING SCRIPTS AND SUBSTITUTIONS} -
{expr:OPERANDS} -
{expr:MATH FUNCTIONS} -
{history:DESCRIPTION} -
{history:HISTORY REVISION} -
{switch:DESCRIPTION} -
{upvar:DESCRIPTION} {
return; # fix.me
}
default {
manerror "ignoring $line"
}
| > | 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 |
{bind:MODIFIERS} -
{bind:EVENT TYPES} -
{bind:BINDING SCRIPTS AND SUBSTITUTIONS} -
{expr:OPERANDS} -
{expr:MATH FUNCTIONS} -
{history:DESCRIPTION} -
{history:HISTORY REVISION} -
{re_syntax:BRACKET EXPRESSIONS} -
{switch:DESCRIPTION} -
{upvar:DESCRIPTION} {
return; # fix.me
}
default {
manerror "ignoring $line"
}
|
| ︙ | ︙ | |||
1271 1272 1273 1274 1275 1276 1277 |
##
## foreach of the man directories specified by args
## convert manpages into hypertext in the directory
## specified by html.
##
proc make-man-pages {html args} {
| | > | 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 |
##
## foreach of the man directories specified by args
## convert manpages into hypertext in the directory
## specified by html.
##
proc make-man-pages {html args} {
global env manual overall_title tcltkdesc
makedirhier $html
set manual(short-toc-n) 1
set manual(short-toc-fp) [open $html/contents.htm w]
puts $manual(short-toc-fp) "<HTML><HEAD><TITLE>$overall_title</TITLE></HEAD>"
puts $manual(short-toc-fp) "<BODY><HR><H3>$overall_title</H3><HR><DL>"
set manual(merge-copyrights) {}
foreach arg $args {
if {$arg == ""} {continue}
set manual(wing-glob) [lindex $arg 0]
set manual(wing-name) [lindex $arg 1]
set manual(wing-file) [lindex $arg 2]
set manual(wing-description) [lindex $arg 3]
set manual(wing-copyrights) {}
makedirhier $html/$manual(wing-file)
set manual(wing-toc-fp) [open $html/$manual(wing-file)/contents.htm w]
|
| ︙ | ︙ | |||
1356 1357 1358 1359 1360 1361 1362 |
}
}
if {"$manual(partial-text)" != {}} {
lappend manual(text) [process-text $manual(partial-text)]
set manual(partial-text) {}
}
switch -exact $code {
| | | | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 |
}
}
if {"$manual(partial-text)" != {}} {
lappend manual(text) [process-text $manual(partial-text)]
set manual(partial-text) {}
}
switch -exact $code {
.SH - .SS {
if {[llength $rest] == 0} {
gets $manual(infp) rest
}
lappend manual(text) "$code [unquote $rest]"
}
.TH {
lappend manual(text) "$code [unquote $rest]"
}
.HS - .UL -
.ta {
lappend manual(text) "$code [unquote $rest]"
|
| ︙ | ︙ | |||
1384 1385 1386 1387 1388 1389 1390 |
lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]]
}
.IP {
regexp {^(.*) +\d+$} $rest all rest
lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]"
}
.TP {
| | > > | 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 |
lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]]
}
.IP {
regexp {^(.*) +\d+$} $rest all rest
lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]"
}
.TP {
while {[is-a-directive [set next [gets $manual(infp)]]]} {
manerror "ignoring $next after .TP"
}
if {"$next" != {'}} {
lappend manual(text) ".IP [process-text $next]"
}
}
.OP {
lappend manual(text) [concat .OP [process-text \
"\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]]
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 |
##
## build the keyword index.
##
proc strcasecmp {a b} { return [string compare -nocase $a $b] }
set keys [lsort -command strcasecmp [array names manual keyword-*]]
makedirhier $html/Keywords
catch {eval file delete -- [glob $html/Keywords/*]}
| | | | | | | | 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 |
##
## build the keyword index.
##
proc strcasecmp {a b} { return [string compare -nocase $a $b] }
set keys [lsort -command strcasecmp [array names manual keyword-*]]
makedirhier $html/Keywords
catch {eval file delete -- [glob $html/Keywords/*]}
puts $manual(short-toc-fp) "<DT><A HREF=\"Keywords/contents.htm\">Keywords</A><DD>The keywords from the $tcltkdesc man pages."
set keyfp [open $html/Keywords/contents.htm w]
puts $keyfp "<HTML><HEAD><TITLE>$tcltkdesc Keywords</TITLE></HEAD>"
puts $keyfp "<BODY><HR><H3>$tcltkdesc Keywords</H3><HR><H2>"
foreach a {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} {
puts $keyfp "<A HREF=\"$a.htm\">$a</A>"
set afp [open $html/Keywords/$a.htm w]
puts $afp "<HTML><HEAD><TITLE>$tcltkdesc Keywords - $a</TITLE></HEAD>"
puts $afp "<BODY><HR><H3>$tcltkdesc Keywords - $a</H3><HR><H2>"
foreach b {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} {
puts $afp "<A HREF=\"$b.htm\">$b</A>"
}
puts $afp "</H2><HR><DL>"
foreach k $keys {
if {[string match -nocase "keyword-${a}*" $k]} {
set k [string range $k 8 end]
puts $afp "<DT><A NAME=\"$k\">$k</A><DD>"
set refs {}
foreach man $manual(keyword-$k) {
set name [lindex $man 0]
set file [lindex $man 1]
lappend refs "<A HREF=\"../$file\">$name</A>"
|
| ︙ | ︙ | |||
1663 1664 1665 1666 1667 1668 1669 |
}
puts $manual(outfp) </BODY></HTML>
close $manual(outfp)
}
return {}
}
| > > > > > > > | < < | | | | | | 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 |
}
puts $manual(outfp) </BODY></HTML>
close $manual(outfp)
}
return {}
}
parse_command_line
set tcltkdesc ""; set cmdesc ""; set appdir ""
if {$build_tcl} {append tcltkdesc "Tcl"; append cmdesc "Tcl"; append appdir "$tcldir"}
if {$build_tcl && $build_tk} {append tcltkdesc "/"; append cmdesc " and "; append appdir ","}
if {$build_tk} {append tcltkdesc "Tk"; append cmdesc "Tk"; append appdir "$tkdir"}
set usercmddesc "The interpreters which implement $cmdesc."
set tclcmddesc {The commands which the <B>tclsh</B> interpreter implements.}
set tkcmddesc {The additional commands which the <B>wish</B> interpreter implements.}
set tcllibdesc {The C functions which a Tcl extended C program may use.}
set tklibdesc {The additional C functions which a Tk extended C program may use.}
if {1} {
if {[catch {
make-man-pages $webdir \
"$tcltkdir/{$appdir}/doc/*.1 \"$tcltkdesc Applications\" UserCmd {$usercmddesc}" \
[expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.n {Tcl Commands} TclCmd {$tclcmddesc}" : ""}] \
[expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.n {Tk Commands} TkCmd {$tkcmddesc}" : ""}] \
[expr {$build_tcl ? "$tcltkdir/$tcldir/doc/*.3 {Tcl Library} TclLib {$tcllibdesc}" : ""}] \
[expr {$build_tk ? "$tcltkdir/$tkdir/doc/*.3 {Tk Library} TkLib {$tklibdesc}" : ""}]
} error]} {
puts $error\n$errorInfo
}
}
|
Changes to unix/Makefile.in.
1 2 3 4 5 6 7 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # # RCS: @(#) $Id: Makefile.in,v 1.121.2.21 2007/06/06 09:54:33 das Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ #---------------------------------------------------------------- |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | mandir = @mandir@ # The following definition can be set to non-null for special systems # like AFS with replication. It allows the pathnames used for installation # to be different than those used for actually reference files at # run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix # when installing files. | | | > > > > > > > > > > > > | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | mandir = @mandir@ # The following definition can be set to non-null for special systems # like AFS with replication. It allows the pathnames used for installation # to be different than those used for actually reference files at # run-time. INSTALL_ROOT is prepended to $prefix and $exec_prefix # when installing files. INSTALL_ROOT = $(DESTDIR) # Path for the platform independent Tcl scripting libraries: TCL_LIBRARY = @TCL_LIBRARY@ # Path to use at runtime to refer to LIB_INSTALL_DIR: LIB_RUNTIME_DIR = $(libdir) # Directory in which to install the program tclsh: BIN_INSTALL_DIR = $(INSTALL_ROOT)$(bindir) # Directory in which to install libtcl.so or libtcl.a: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tcl header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(PRIVATE_INCLUDE_DIR) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library # procedures: MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 # Directory in which to install manual entries for the built-in # Tcl commands: MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann # Path to the html documentation dir: HTML_DIR = @HTML_DIR@ # Directory in which to install html documentation: HTML_INSTALL_DIR = $(INSTALL_ROOT)$(HTML_DIR) # Package search path. TCL_PACKAGE_PATH = @TCL_PACKAGE_PATH@ # Libraries built with optimization switches have this additional extension TCL_DBGX = @TCL_DBGX@ # warning flags CFLAGS_WARNING = @CFLAGS_WARNING@ # The default switches for optimization or debugging CFLAGS_DEBUG = @CFLAGS_DEBUG@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ -DTCL_DBGX=$(TCL_DBGX) # Flags to pass to the linker LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ # To disable ANSI-C procedure prototypes reverse the comment characters # on the following lines: PROTO_FLAGS = #PROTO_FLAGS = -DNO_PROTOTYPE # Mathematical functions like sin and atan2 are enabled for expressions |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | # following pairs of lines. In addition, you'll have to provide your # own replacement for the "panic" procedure (see panic.c for what # the current one does). GENERIC_FLAGS = #GENERIC_FLAGS = -DTCL_GENERIC_ONLY UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ | | > | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | # following pairs of lines. In addition, you'll have to provide your # own replacement for the "panic" procedure (see panic.c for what # the current one does). GENERIC_FLAGS = #GENERIC_FLAGS = -DTCL_GENERIC_ONLY UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ tclUnixTime.o tclUnixInit.o tclUnixThrd.o \ tclUnixCompat.o #UNIX_OBJS = NOTIFY_OBJS = tclUnixNotfy.o #NOTIFY_OBJS = # To enable memory debugging reverse the comment characters on the following # lines or call configure with --enable-symbols=mem # Warning: if you enable memory debugging, you must do it *everywhere*, |
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | # Tcl used to let the configure script choose which program to use # for installing, but there are just too many different versions of # "install" around; better to use the install-sh script that comes # with the distribution, which is slower but guaranteed to work. INSTALL_STRIP_PROGRAM = -s | | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
# Tcl used to let the configure script choose which program to use
# for installing, but there are just too many different versions of
# "install" around; better to use the install-sh script that comes
# with the distribution, which is slower but guaranteed to work.
INSTALL_STRIP_PROGRAM = -s
INSTALL_STRIP_LIBRARY = -S -S
INSTALL = @srcdir@/install-sh -c
INSTALL_PROGRAM = ${INSTALL}
INSTALL_LIBRARY = ${INSTALL}
INSTALL_DATA = ${INSTALL} -m 644
# TCL_EXE is the name of a tclsh executable that is available *BEFORE*
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 | # symbols mean. The values of the symbols are normally set by the # configure script. You shouldn't normally need to modify any of # these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ | < | 202 203 204 205 206 207 208 209 210 211 212 213 214 215 | # symbols mean. The values of the symbols are normally set by the # configure script. You shouldn't normally need to modify any of # these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ #SHLIB_SUFFIX = DLTEST_TARGETS = dltest.marker |
| ︙ | ︙ | |||
235 236 237 238 239 240 241 | # The information below is modified by the configure script when # Makefile is generated from Makefile.in. You shouldn't normally # modify any of this stuff by hand. #---------------------------------------------------------------- COMPAT_OBJS = @LIBOBJS@ | | | | | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 | # The information below is modified by the configure script when # Makefile is generated from Makefile.in. You shouldn't normally # modify any of this stuff by hand. #---------------------------------------------------------------- COMPAT_OBJS = @LIBOBJS@ AC_FLAGS = @DEFS@ AR = @AR@ RANLIB = @RANLIB@ SRC_DIR = @srcdir@ TOP_DIR = $(SRC_DIR)/.. GENERIC_DIR = $(TOP_DIR)/generic COMPAT_DIR = $(TOP_DIR)/compat TOOL_DIR = $(TOP_DIR)/tools UNIX_DIR = $(SRC_DIR) MAC_OSX_DIR = $(TOP_DIR)/macosx # Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below. DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest # Must be absolute to so the corresponding tcltest's tcl_library is absolute. TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library CC = @CC@ #CC = purify -best-effort @CC@ -DPURIFY # Flags to be passed to installManPage to control whether the manpages # should be compressed and linked with softlinks MAN_FLAGS = @MAN_FLAGS@ #---------------------------------------------------------------- # The information below is usually usable as is. The configure # script won't modify it and it only exists to make working # around selected rare system configurations easier. #---------------------------------------------------------------- |
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
#----------------------------------------------------------------
CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I${GENERIC_DIR} -I${SRC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \
${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} ${ENV_FLAGS} \
| | | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
#----------------------------------------------------------------
CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I${GENERIC_DIR} -I${SRC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \
${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} ${ENV_FLAGS} \
-DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" @EXTRA_CC_SWITCHES@
STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I${GENERIC_DIR} -I${SRC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} ${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \
${COMPILE_DEBUG_FLAGS} ${ENV_FLAGS} -DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" @EXTRA_CC_SWITCHES@
LIBS = @DL_LIBS@ @LIBS@ $(MATH_LIBS)
DEPEND_SWITCHES = ${CFLAGS} -I${GENERIC_DIR} -I${SRC_DIR} \
${AC_FLAGS} ${MATH_FLAGS} \
${GENERIC_FLAGS} ${PROTO_FLAGS} ${MEM_DEBUG_FLAGS} \
-DTCL_SHLIB_EXT=\"${SHLIB_SUFFIX}\" @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
tclThreadTest.o tclUnixTest.o
XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
|
| ︙ | ︙ | |||
314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPipe.o \
tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o tclRegexp.o \
tclResolve.o tclResult.o tclScan.o tclStringObj.o tclThread.o \
tclThreadAlloc.o tclThreadJoin.o tclStubInit.o tclStubLib.o \
tclTimer.o tclUtf.o tclUtil.o tclVar.o
STUB_LIB_OBJS = tclStubLib.o ${COMPAT_OBJS}
OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \
@DL_OBJS@ @PLAT_OBJS@
TCL_DECLS = \
$(GENERIC_DIR)/tcl.decls \
$(GENERIC_DIR)/tclInt.decls
| > > | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPipe.o \
tclPkg.o tclPosixStr.o tclPreserve.o tclProc.o tclRegexp.o \
tclResolve.o tclResult.o tclScan.o tclStringObj.o tclThread.o \
tclThreadAlloc.o tclThreadJoin.o tclStubInit.o tclStubLib.o \
tclTimer.o tclUtf.o tclUtil.o tclVar.o
STUB_LIB_OBJS = tclStubLib.o ${COMPAT_OBJS}
MAC_OSX_OBJS = tclMacOSXBundle.o tclMacOSXNotify.o
OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \
@DL_OBJS@ @PLAT_OBJS@
TCL_DECLS = \
$(GENERIC_DIR)/tcl.decls \
$(GENERIC_DIR)/tclInt.decls
|
| ︙ | ︙ | |||
411 412 413 414 415 416 417 | UNIX_SRCS = \ $(UNIX_DIR)/tclAppInit.c \ $(UNIX_DIR)/tclUnixChan.c \ $(UNIX_DIR)/tclUnixEvent.c \ $(UNIX_DIR)/tclUnixFCmd.c \ $(UNIX_DIR)/tclUnixFile.c \ | < | > > > > | > | | 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
UNIX_SRCS = \
$(UNIX_DIR)/tclAppInit.c \
$(UNIX_DIR)/tclUnixChan.c \
$(UNIX_DIR)/tclUnixEvent.c \
$(UNIX_DIR)/tclUnixFCmd.c \
$(UNIX_DIR)/tclUnixFile.c \
$(UNIX_DIR)/tclUnixPipe.c \
$(UNIX_DIR)/tclUnixSock.c \
$(UNIX_DIR)/tclUnixTest.c \
$(UNIX_DIR)/tclUnixThrd.c \
$(UNIX_DIR)/tclUnixTime.c \
$(UNIX_DIR)/tclUnixInit.c \
$(UNIX_DIR)/tclUnixCompat.c
NOTIFY_SRCS = \
$(UNIX_DIR)/tclUnixNotfy.c
DL_SRCS = \
$(UNIX_DIR)/tclLoadAix.c \
$(UNIX_DIR)/tclLoadAout.c \
$(UNIX_DIR)/tclLoadDl.c \
$(UNIX_DIR)/tclLoadDl2.c \
$(UNIX_DIR)/tclLoadDld.c \
$(UNIX_DIR)/tclLoadDyld.c \
$(GENERIC_DIR)/tclLoadNone.c \
$(UNIX_DIR)/tclLoadOSF.c \
$(UNIX_DIR)/tclLoadShl.c
MAC_OSX_SRCS = \
$(MAC_OSX_DIR)/tclMacOSXBundle.c \
$(MAC_OSX_DIR)/tclMacOSXNotify.c
# Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those
# files won't compile on the current machine, and they will cause
# problems for things like "make depend".
SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) $(STUB_SRCS) @PLAT_SRCS@
all: binaries libraries doc
binaries: ${LIB_FILE} $(STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh
libraries:
|
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
@echo ${OBJS}
# This targets actually build the objects needed for the lib in the above
# case
objs: ${OBJS}
tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE}
| | | | | | | | | > > | | > > > > > | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
@echo ${OBJS}
# This targets actually build the objects needed for the lib in the above
# case
objs: ${OBJS}
tclsh: ${TCLSH_OBJS} ${TCL_LIB_FILE}
${CC} ${CFLAGS} ${LDFLAGS} ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o tclsh
# Resetting the LIB_RUNTIME_DIR below is required so that
# the generated tcltest executable gets the build directory
# burned into its ld search path. This keeps tcltest from
# picking up an already installed version of the Tcl library.
tcltest: ${TCLTEST_OBJS} ${TCL_LIB_FILE} ${BUILD_DLTEST}
$(MAKE) tcltest-real LIB_RUNTIME_DIR=`pwd`
tcltest-real:
${CC} ${CFLAGS} ${LDFLAGS} ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${LIBS} @EXTRA_TCLSH_LIBS@ \
${CC_SEARCH_FLAGS} -o tcltest
# Note, in the target below TCL_LIBRARY needs to be set or else
# "make test" won't work in the case where the compilation directory
# isn't the same as the source directory.
# Specifying TESTFLAGS on the command line is the standard way to pass
# args to tcltest, ie:
# % make test TESTFLAGS="-verbose bps -file fileName.test"
test: tcltest
@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
./tcltest $(TOP_DIR)/tests/all.tcl $(TESTFLAGS) $(TCLTESTARGS)
# Useful target to launch a built tcltest with the proper path,...
runtest: tcltest
@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
./tcltest
# Useful target for running the test suite with an unwritable current
# directory...
ro-test: tcltest
@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
echo 'exec chmod -w .;package require tcltest;tcltest::temporaryDirectory /tmp;source ../tests/all.tcl;exec chmod +w .' | ./tcltest
# This target can be used to run tclsh from the build directory
# via `make shell SCRIPT=/tmp/foo.tcl`
shell: tclsh
@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
./tclsh $(SCRIPT)
# This target can be used to run tclsh inside either gdb or insight
gdb: tclsh
@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run
@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
$(GDB) ./tclsh --command=gdb.run
rm gdb.run
# This target can be used to run tclsh inside ddd
ddd: tclsh
@echo "set env @LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}" > gdb.run
@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
$(DDD) -command=gdb.run ./tclsh
rm gdb.run
VALGRINDARGS=--tool=memcheck --num-callers=8 --leak-resolution=high --leak-check=yes --show-reachable=yes -v
valgrind: tclsh tcltest
@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
valgrind $(VALGRINDARGS) ./tcltest $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS) $(TCLTESTARGS)
valgrindshell: tclsh
@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
valgrind $(VALGRINDARGS) ./tclsh $(SCRIPT)
# The following target outputs the name of the top-level source directory
# for Tcl (it is used by Tk's configure script, for example). The
# .NO_PARALLEL line is needed to avoid problems under Sun's "pmake".
# Note: this target is now obsolete (use the autoconf variable
# TCL_SRC_DIR from tclConfig.sh instead).
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 | # target (via the BUILD_DLTEST variable) if dynamic loading is supported # on this platform. The Makefile in the dltest subdirectory creates # the dltest.marker file in this directory after a successful build. dltest.marker: cd dltest ; $(MAKE) | | > > | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 |
# target (via the BUILD_DLTEST variable) if dynamic loading is supported
# on this platform. The Makefile in the dltest subdirectory creates
# the dltest.marker file in this directory after a successful build.
dltest.marker:
cd dltest ; $(MAKE)
INSTALL_TARGETS = install-binaries install-libraries install-doc @EXTRA_INSTALL@
install: $(INSTALL_TARGETS)
install-strip:
$(MAKE) $(INSTALL_TARGETS) \
INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \
INSTALL_LIBRARY="$(INSTALL_LIBRARY) ${INSTALL_STRIP_LIBRARY}"
# Note: before running ranlib below, must cd to target directory because
# some ranlibs write to current directory, and this might not always be
# possible (e.g. if installing as root).
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 | @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) @echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/" @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh @if test "$(STUB_LIB_FILE)" != "" ; then \ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ fi install-libraries: libraries @for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ mkdir -p $$i; \ chmod 755 $$i; \ else true; \ fi; \ done; | > | | | | | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 | @$(INSTALL_PROGRAM) tclsh $(BIN_INSTALL_DIR)/tclsh$(VERSION) @echo "Installing tclConfig.sh to $(LIB_INSTALL_DIR)/" @$(INSTALL_DATA) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh @if test "$(STUB_LIB_FILE)" != "" ; then \ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ fi @EXTRA_INSTALL_BINARIES@ install-libraries: libraries @for i in $(INCLUDE_INSTALL_DIR) $(SCRIPT_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ mkdir -p $$i; \ chmod 755 $$i; \ else true; \ fi; \ done; @for i in http2.5 http1.0 opt0.4 encoding msgcat1.3 tcltest2.2; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ mkdir -p $(SCRIPT_INSTALL_DIR)/$$i; \ chmod 755 $(SCRIPT_INSTALL_DIR)/$$i; \ else true; \ fi; \ done; @if test ! -x $(SRC_DIR)/install-sh; then \ chmod +x $(SRC_DIR)/install-sh; \ fi @echo "Installing header files"; @for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \ $(GENERIC_DIR)/tclPlatDecls.h; \ do \ $(INSTALL_DATA) $$i $(INCLUDE_INSTALL_DIR); \ done; @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex $(UNIX_DIR)/tclAppInit.c $(UNIX_DIR)/ldAix; \ do \ $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR); \ done; @echo "Installing library http1.0 directory"; @for j in $(TOP_DIR)/library/http1.0/*.tcl ; \ do \ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http1.0; \ done; @echo "Installing library http2.5 directory"; @for j in $(TOP_DIR)/library/http/*.tcl ; \ do \ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http2.5; \ done; @echo "Installing library opt0.4 directory"; @for j in $(TOP_DIR)/library/opt/*.tcl ; \ do \ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/opt0.4; \ done; @echo "Installing library msgcat1.3 directory"; |
| ︙ | ︙ | |||
676 677 678 679 680 681 682 | done; @echo "Installing library encoding directory"; @for i in $(TOP_DIR)/library/encoding/*.enc ; do \ $(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \ done; install-doc: doc | | | | | > | | < > | | | | < | | > > > > > > > > | < | > | < > | > | | > > | < < < < > | > | | > > > > | | | 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 |
done;
@echo "Installing library encoding directory";
@for i in $(TOP_DIR)/library/encoding/*.enc ; do \
$(INSTALL_DATA) $$i $(SCRIPT_INSTALL_DIR)/encoding; \
done;
install-doc: doc
@if test ! -x $(UNIX_DIR)/installManPage; then \
chmod +x $(UNIX_DIR)/installManPage; \
fi
@for i in $(MAN_INSTALL_DIR) $(MAN1_INSTALL_DIR) $(MAN3_INSTALL_DIR) $(MANN_INSTALL_DIR) ; \
do \
if [ ! -d $$i ] ; then \
echo "Making directory $$i"; \
mkdir -p $$i; \
chmod 755 $$i; \
else true; \
fi; \
done;
@echo "Installing and cross-linking top-level (.1) docs";
@for i in $(TOP_DIR)/doc/*.1; do \
$(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i $(MAN1_INSTALL_DIR); \
done
@echo "Installing and cross-linking C API (.3) docs";
@for i in $(TOP_DIR)/doc/*.3; do \
$(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i $(MAN3_INSTALL_DIR); \
done
@echo "Installing and cross-linking command (.n) docs";
@for i in $(TOP_DIR)/doc/*.n; do \
$(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i $(MANN_INSTALL_DIR); \
done
# Optional target to install private headers
install-private-headers: libraries
@for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \
do \
if [ ! -d $$i ] ; then \
echo "Making directory $$i"; \
mkdir -p $$i; \
chmod 755 $$i; \
else true; \
fi; \
done;
@if test ! -x $(SRC_DIR)/install-sh; then \
chmod +x $(SRC_DIR)/install-sh; \
fi
@echo "Installing private header files";
@for i in $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \
$(GENERIC_DIR)/tclIntPlatDecls.h \
$(UNIX_DIR)/tclUnixPort.h $(GENERIC_DIR)/tclMath.h; \
do \
$(INSTALL_DATA) $$i $(PRIVATE_INCLUDE_INSTALL_DIR); \
done;
@sed -e 's#\.\./unix/##' $(GENERIC_DIR)/tclPort.h > tclPort.h; \
$(INSTALL_DATA) tclPort.h $(PRIVATE_INCLUDE_INSTALL_DIR); \
rm -f tclPort.h
Makefile: $(UNIX_DIR)/Makefile.in $(DLTEST_DIR)/Makefile.in
$(SHELL) config.status
clean:
rm -f *.a *.o libtcl* core errs *~ \#* TAGS *.E a.out \
errors tclsh tcltest lib.exp Tcl
cd dltest ; $(MAKE) clean
distclean: clean
rm -rf Makefile config.status config.cache config.log tclConfig.sh \
$(PACKAGE).* prototype *.plist Tcl.framework
cd dltest ; $(MAKE) distclean
depend:
makedepend -- $(DEPEND_SWITCHES) -- $(SRCS)
# Test binaries. The rules for tclTestInit.o and xtTestInit.o are
# complicated because they are compiled from tclAppInit.c. Can't use
# the "-o" option because this doesn't work on some strange compilers
# (e.g. UnixWare).
# To enable concurrent parallel make of tclsh and tcltest resp xttest, these
# targets have to depend on tclsh, this ensures that linking of tclsh with
# tclAppInit.o does not execute concurrently with the renaming and recompiling
# of that same object file in the targets below.
tclTestInit.o: $(UNIX_DIR)/tclAppInit.c tclsh
@if test -f tclAppInit.o ; then \
rm -f tclAppInit.sav; \
mv tclAppInit.o tclAppInit.sav; \
fi;
$(CC) -c $(CC_SWITCHES) \
-DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \
-DTCL_TEST $(UNIX_DIR)/tclAppInit.c
rm -f tclTestInit.o
mv tclAppInit.o tclTestInit.o
@if test -f tclAppInit.sav ; then \
mv tclAppInit.sav tclAppInit.o; \
fi;
xtTestInit.o: $(UNIX_DIR)/tclAppInit.c tclsh
@if test -f tclAppInit.o ; then \
rm -f tclAppInit.sav; \
mv tclAppInit.o tclAppInit.sav; \
fi;
$(CC) -c $(CC_SWITCHES) \
-DTCL_BUILDTIME_LIBRARY="\"${TCL_BUILDTIME_LIBRARY}\"" \
-DTCL_TEST -DTCL_XT_TEST $(UNIX_DIR)/tclAppInit.c
|
| ︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 |
$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c
tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c $(GENERIC_DIR)/tclInitScript.h tclConfig.sh
$(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \
$(UNIX_DIR)/tclUnixInit.c
| > > | > > > > | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 |
$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixTime.c
tclUnixInit.o: $(UNIX_DIR)/tclUnixInit.c $(GENERIC_DIR)/tclInitScript.h tclConfig.sh
$(CC) -c $(CC_SWITCHES) -DTCL_LIBRARY=\"${TCL_LIBRARY}\" \
-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\"" \
$(UNIX_DIR)/tclUnixInit.c
tclUnixCompat.o: $(UNIX_DIR)/tclUnixCompat.c
$(CC) -c $(CC_SWITCHES) $(UNIX_DIR)/tclUnixCompat.c
# The following are Mac OS X only sources:
tclMacOSXBundle.o: $(MAC_OSX_DIR)/tclMacOSXBundle.c
$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXBundle.c
tclMacOSXNotify.o: $(MAC_OSX_DIR)/tclMacOSXNotify.c
$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXNotify.c
# The following targets are not completely general. They are provide
# purely for documentation purposes so people who are interested in
# the Xt based notifier can modify them to suit their own installation.
xttest: ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
@DL_OBJS@ ${BUILD_DLTEST}
${CC} ${XTTEST_OBJS} ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS} \
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 | waitpid.o: $(COMPAT_DIR)/waitpid.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive | < | 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 | waitpid.o: $(COMPAT_DIR)/waitpid.c $(CC) -c $(STUB_CC_SWITCHES) $(COMPAT_DIR)/waitpid.c # Stub library binaries, these must be compiled for use in a shared library # even though they will be placed in a static archive tclStubLib.o: $(GENERIC_DIR)/tclStubLib.c $(CC) -c $(STUB_CC_SWITCHES) $(GENERIC_DIR)/tclStubLib.c .c.o: $(CC) -c $(CC_SWITCHES) $< # |
| ︙ | ︙ | |||
1132 1133 1134 1135 1136 1137 1138 | $(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls # # Target to check that all exported functions have an entry in the stubs # tables. # | | | > | | | 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 |
$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls
#
# Target to check that all exported functions have an entry in the stubs
# tables.
#
checkstubs: $(TCL_LIB_FILE)
-@for i in `nm -p $(TCL_LIB_FILE) \
| awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \
| sort -n`; do \
match=0; \
for j in $(TCL_DECLS); do \
if [ `grep -c "$$i *(" $$j` -gt 0 ]; then \
match=1; \
fi; \
done; \
if [ $$match -eq 0 ]; then echo $$i; fi \
done
#
# Target to check that all public APIs which are not command
# implementations have an entry in section three of the distributed
# manpages.
#
checkdoc: $(TCL_LIB_FILE)
-@for i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \
| grep -v 'Cmd$$' | sort -n`; do \
match=0; \
for j in $(TOP_DIR)/doc/*.3; do \
if [ `grep '\-' $$j | grep -c $$i` -gt 0 ]; then \
match=1; \
fi; \
|
| ︙ | ︙ | |||
1175 1176 1177 1178 1179 1180 1181 | # # Target to make sure that only symbols with "Tcl" prefixes are # exported. # checkexports: $(TCL_LIB_FILE) | | > > < < < < < | < < | | | 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 |
#
# Target to make sure that only symbols with "Tcl" prefixes are
# exported.
#
checkexports: $(TCL_LIB_FILE)
-@nm -p $(TCL_LIB_FILE) \
| awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \
| sort -n | grep -E -v '^[Tt]cl' || true
#
# Target to create a Tcl RPM for Linux. Requires that you be on a Linux
# system.
#
rpm: all /bin/rpm
rm -f THIS.TCL.SPEC
echo "%define _builddir `pwd`" > THIS.TCL.SPEC
echo "%define _rpmdir `pwd`/RPMS" >> THIS.TCL.SPEC
cat tcl.spec >> THIS.TCL.SPEC
mkdir -p RPMS/i386
rpm -bb THIS.TCL.SPEC
mv RPMS/i386/*.rpm .
rm -rf RPMS THIS.TCL.SPEC
#
# Target to create a proper Tcl distribution from information in the
# master source directory. DISTDIR must be defined to indicate where
# to put the distribution. DISTDIR must be an absolute path name.
#
DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
DISTDIR = $(DISTROOT)/$(DISTNAME)
dist:
rm -rf $(DISTDIR)
mkdir -p $(DISTDIR)/unix
cp -p $(UNIX_DIR)/*.c $(UNIX_DIR)/*.h $(DISTDIR)/unix
cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
chmod 664 $(DISTDIR)/unix/Makefile.in
cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.in \
$(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \
$(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/install-sh \
$(UNIX_DIR)/README $(UNIX_DIR)/ldAix $(UNIX_DIR)/tcl.spec \
$(UNIX_DIR)/installManPage \
$(DISTDIR)/unix
chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.in
chmod 775 $(DISTDIR)/unix/ldAix
chmod +x $(DISTDIR)/unix/install-sh
mkdir $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.c $(GENERIC_DIR)/*.h $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 | done; mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc mkdir $(DISTDIR)/compat | | | | 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 | done; mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding mkdir $(DISTDIR)/doc cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \ $(TOP_DIR)/doc/man.macros $(DISTDIR)/doc mkdir $(DISTDIR)/compat cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.c \ $(COMPAT_DIR)/*.h $(COMPAT_DIR)/README \ $(DISTDIR)/compat mkdir $(DISTDIR)/tests cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \ $(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \ $(DISTDIR)/tests mkdir $(DISTDIR)/win |
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 | $(TOP_DIR)/mac/*.c $(TOP_DIR)/mac/*.h $(TOP_DIR)/mac/*.r \ $(DISTDIR)/mac cp -p $(TOP_DIR)/mac/porting.notes $(TOP_DIR)/mac/README $(DISTDIR)/mac cp -p $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac cp -p $(TOP_DIR)/mac/*.doc $(TOP_DIR)/mac/*.html $(DISTDIR)/mac cp -p $(TOP_DIR)/license.terms $(DISTDIR)/mac mkdir $(DISTDIR)/macosx | | | > | | | | | | | 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 | $(TOP_DIR)/mac/*.c $(TOP_DIR)/mac/*.h $(TOP_DIR)/mac/*.r \ $(DISTDIR)/mac cp -p $(TOP_DIR)/mac/porting.notes $(TOP_DIR)/mac/README $(DISTDIR)/mac cp -p $(TOP_DIR)/mac/*.pch $(DISTDIR)/mac cp -p $(TOP_DIR)/mac/*.doc $(TOP_DIR)/mac/*.html $(DISTDIR)/mac cp -p $(TOP_DIR)/license.terms $(DISTDIR)/mac mkdir $(DISTDIR)/macosx cp -p $(MAC_OSX_DIR)/Makefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ $(DISTDIR)/macosx cp -p $(TOP_DIR)/license.terms $(DISTDIR)/macosx mkdir $(DISTDIR)/macosx/Tcl.pbproj cp -p $(MAC_OSX_DIR)/Tcl.pbproj/*.pbx* $(DISTDIR)/macosx/Tcl.pbproj mkdir $(DISTDIR)/unix/dltest cp -p $(UNIX_DIR)/dltest/*.c $(UNIX_DIR)/dltest/Makefile.in \ $(UNIX_DIR)/dltest/README \ $(DISTDIR)/unix/dltest mkdir $(DISTDIR)/tools cp -p $(TOOL_DIR)/Makefile.in $(TOOL_DIR)/README \ $(TOOL_DIR)/configure $(TOOL_DIR)/configure.in \ $(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \ $(TOOL_DIR)/tcl.wse.in $(TOOL_DIR)/*.bmp \ $(TOOL_DIR)/tcl.hpj.in \ $(DISTDIR)/tools $(TCL_EXE) $(TOOL_DIR)/eolFix.tcl -crlf $(DISTDIR)/tools/tcl.hpj.in \ $(DISTDIR)/tools/tcl.wse.in # # The following target can only be used for non-patch releases. Use # the "allpatch" target below for patch releases. |
| ︙ | ︙ | |||
1337 1338 1339 1340 1341 1342 1343 |
mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME)
mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION}
#
# This target creates the HTML folder for Tcl & Tk and places it
# in DISTDIR/html. It uses the tcltk-man2html.tcl tool from
# the Tcl group's tool workspace. It depends on the Tcl & Tk being
| | | > > > > > > > > > > > > | | | 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 |
mv $(DISTROOT)/tcl${VERSION} $(DISTROOT)/$(DISTNAME)
mv $(DISTROOT)/old $(DISTROOT)/tcl${VERSION}
#
# This target creates the HTML folder for Tcl & Tk and places it
# in DISTDIR/html. It uses the tcltk-man2html.tcl tool from
# the Tcl group's tool workspace. It depends on the Tcl & Tk being
# in directories called tcl8.* & tk8.* up two directories from the
# TOOL_DIR.
#
html: tclsh
$(BUILD_HTML)
@EXTRA_BUILD_HTML@
html-tcl: tclsh
$(BUILD_HTML) --tcl
@EXTRA_BUILD_HTML@
html-tk: tclsh
$(BUILD_HTML) --tk
@EXTRA_BUILD_HTML@
BUILD_HTML = \
@@LD_LIBRARY_PATH_VAR@=`pwd`:$${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
./tclsh $(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) \
--srcdir=$(TOP_DIR)/.. $(BUILD_HTML_FLAGS)
#
# Target to create a Macintosh version of the distribution. This will
# do a normal distribution and then massage the output to prepare it
# for moving to the Mac platform. This requires a few scripts and
# programs found only in the Tcl group's tool workspace.
#
|
| ︙ | ︙ |
Changes to unix/README.
1 2 3 | Tcl UNIX README --------------- | | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
Tcl UNIX README
---------------
RCS: @(#) $Id: README,v 1.24.2.2 2005/12/03 00:35:44 das Exp $
This is the directory where you configure, compile, test, and install
UNIX versions of Tcl. This directory also contains source files for Tcl
that are specific to UNIX. Some of the files in this directory are
used on the PC or Mac platform too, but they all depend on UNIX
(POSIX/ANSI C) interfaces and some of them only make sense under UNIX.
Updated forms of the information found in this file is available at:
http://www.tcl.tk/doc/howto/compile.html#unix
For information on platforms where Tcl is known to compile, along
with any porting notes for getting it to work on those platforms, see:
http://www.tcl.tk/software/tcltk/platforms.html
The rest of this file contains instructions on how to do this. The
release should compile and run either "out of the box" or with trivial
changes on any UNIX-like system that approximates POSIX, BSD, or System
V. We know that it runs on workstations from Sun, H-P, DEC, IBM, and
SGI, as well as PCs running Linux, BSDI, and SCO UNIX. To compile for
a PC running Windows, see the README file in the directory ../win. To
compile for Max OS X, see the README in the directory ../macosx. To
compile for a classic Macintosh, see the README file in the directory ../mac.
How To Compile And Install Tcl:
-------------------------------
(a) If you have already compiled Tcl once in this directory and are now
preparing to compile again in the same directory but for a different
platform, or if you have applied patches, type "make distclean" to
|
| ︙ | ︙ | |||
78 79 80 81 82 83 84 85 86 87 88 89 90 91 |
default on platforms where nl_langinfo is
found.
--disable-langinfo Specifically disables use of nl_langinfo.
--enable-man-symlinks Use symlinks for linking the manpages that
should be reachable under several names.
--enable-man-compression=PROG
Compress the manpages using PROG.
Note: by default gcc will be used if it can be located on the PATH.
if you want to use cc instead of gcc, set the CC environment variable
to "cc" before running configure. It is not safe to edit the
Makefile to use gcc after configure is run. Also note that
you should use the same compiler when building extensions.
| > > > > > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
default on platforms where nl_langinfo is
found.
--disable-langinfo Specifically disables use of nl_langinfo.
--enable-man-symlinks Use symlinks for linking the manpages that
should be reachable under several names.
--enable-man-compression=PROG
Compress the manpages using PROG.
Mac OS X only:
--enable-framework package Tcl as a framework.
--disable-corefoundation disable use of CoreFoundation API and revert to
standard select based notifier, required when
using naked fork (i.e. not followed by execve).
Note: by default gcc will be used if it can be located on the PATH.
if you want to use cc instead of gcc, set the CC environment variable
to "cc" before running configure. It is not safe to edit the
Makefile to use gcc after configure is run. Also note that
you should use the same compiler when building extensions.
|
| ︙ | ︙ |
Changes to unix/configure.
more than 10,000 changes
Changes to unix/configure.in.
1 2 3 4 5 | #! /bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. # | | | | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | > | < | | | | | > > > > > | | | > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
#! /bin/bash -norc
dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.106.2.37 2007/06/06 09:54:35 das Exp $
AC_INIT(../generic/tcl.h)
AC_PREREQ(2.13)
TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL=".16"
VERSION=${TCL_VERSION}
#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
if test "${prefix}" = "NONE"; then
prefix=/usr/local
fi
if test "${exec_prefix}" = "NONE"; then
exec_prefix=$prefix
fi
# Make sure srcdir is fully qualified!
srcdir=`cd $srcdir ; pwd`
TCL_SRC_DIR=`cd $srcdir/..; pwd`
#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------
SC_CONFIG_MANPAGES([tcl])
#------------------------------------------------------------------------
# Standard compiler checks
#------------------------------------------------------------------------
# If the user did not set CFLAGS, set it now to keep
# the AC_PROG_CC macro from adding "-g -O2".
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
AC_PROG_CC
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special notes:
# - stdlib.h doesn't define strtol, strtoul, or
# strtod insome versions of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
# Do this early, otherwise an autoconf bug throws errors on configure
#--------------------------------------------------------------------
SC_MISSING_POSIX_HEADERS
#------------------------------------------------------------------------
# If we're using GCC, see if the compiler understands -pipe. If so, use it.
# It makes compiling go faster. (This is only a performance feature.)
#------------------------------------------------------------------------
if test -z "$no_pipe" && test -n "$GCC"; then
AC_CACHE_CHECK([if the compiler understands -pipe],
tcl_cv_cc_pipe, [
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -pipe"
AC_TRY_COMPILE(,, tcl_cv_cc_pipe=yes, tcl_cv_cc_pipe=no)
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_pipe = yes; then
CFLAGS="$CFLAGS -pipe"
fi
fi
#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------
SC_ENABLE_THREADS
#--------------------------------------------------------------------
# Look for libraries that we will need when compiling the Tcl shell
#--------------------------------------------------------------------
SC_TCL_LINK_LIBS
# Add the threads support libraries
LIBS="$LIBS$THREADS_LIBS"
SC_ENABLE_SHARED
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
SC_CONFIG_CFLAGS
SC_ENABLE_SYMBOLS
TCL_DBGX=${DBGX}
#--------------------------------------------------------------------
# Detect what compiler flags to set for 64-bit support.
#--------------------------------------------------------------------
SC_TCL_EARLY_FLAGS
|
| ︙ | ︙ | |||
90 91 92 93 94 95 96 | #-------------------------------------------------------------------- # Check if Posix compliant getcwd exists, if not we'll use getwd. AC_CHECK_FUNCS(getcwd, , [AC_DEFINE(USEGETWD)]) # Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really # define USEGETWD even if the posix getcwd exists. Add a test ? | | < < > > > > > > > | < < < < < > | > > > > > > > > > > > > > > > > > > > > > > | < | < | | | < | | < | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
#--------------------------------------------------------------------
# Check if Posix compliant getcwd exists, if not we'll use getwd.
AC_CHECK_FUNCS(getcwd, , [AC_DEFINE(USEGETWD)])
# Nb: if getcwd uses popen and pwd(1) (like SunOS 4) we should really
# define USEGETWD even if the posix getcwd exists. Add a test ?
AC_REPLACE_FUNCS(opendir strstr strtol strtoll strtoull tmpnam waitpid)
AC_CHECK_FUNC(strerror, , [AC_DEFINE(NO_STRERROR)])
AC_CHECK_FUNC(getwd, , [AC_DEFINE(NO_GETWD)])
AC_CHECK_FUNC(wait3, , [AC_DEFINE(NO_WAIT3)])
AC_CHECK_FUNC(uname, , [AC_DEFINE(NO_UNAME)])
if test "`uname -s`" = "Darwin" && test "${TCL_THREADS}" = 1 && \
test "`uname -r | awk -F. '{print [$]1}'`" -lt 7; then
# prior to Darwin 7, realpath is not threadsafe, so don't
# use it when threads are enabled, c.f. bug # 711232
ac_cv_func_realpath=no
fi
AC_CHECK_FUNC(realpath, , [AC_DEFINE(NO_REALPATH)])
#--------------------------------------------------------------------
# Look for thread-safe variants of some library functions.
#--------------------------------------------------------------------
if test "${TCL_THREADS}" = 1; then
SC_TCL_GETPWUID_R
SC_TCL_GETPWNAM_R
SC_TCL_GETGRGID_R
SC_TCL_GETGRNAM_R
if test "`uname -s`" = "Darwin" && \
test "`uname -r | awk -F. '{print [$]1}'`" -gt 5; then
# Starting with Darwin 6 (Mac OSX 10.2), gethostbyX
# are actually MT-safe as they always return pointers
# from the TSD instead of the static storage.
AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME)
AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR)
elif test "`uname -s`" = "HP-UX" && \
test "`uname -r|sed -e 's|B\.||' -e 's|\..*$||'`" -gt 10; then
# Starting with HPUX 11.00 (we believe), gethostbyX
# are actually MT-safe as they always return pointers
# from TSD instead of static storage.
AC_DEFINE(HAVE_MTSAFE_GETHOSTBYNAME)
AC_DEFINE(HAVE_MTSAFE_GETHOSTBYADDR)
else
SC_TCL_GETHOSTBYNAME_R
SC_TCL_GETHOSTBYADDR_R
fi
fi
#---------------------------------------------------------------------------
# Determine which interface to use to talk to the serial port.
# Note that #include lines must begin in leftmost column for
# some compilers to recognize them as preprocessor directives.
#---------------------------------------------------------------------------
SC_SERIAL_PORT
#--------------------------------------------------------------------
# Include sys/select.h if it exists and if it supplies things
# that appear to be useful and aren't already in sys/types.h.
# This appears to be true only on the RS/6000 under AIX. Some
# systems like OSF/1 have a sys/select.h that's of no use, and
# other systems like SCO UNIX have a sys/select.h that's
# pernicious. If "fd_set" isn't defined anywhere then set a
# special flag.
#--------------------------------------------------------------------
AC_CACHE_CHECK([for fd_set in sys/types], tcl_cv_type_fd_set, [
AC_TRY_COMPILE([#include <sys/types.h>],[fd_set readMask, writeMask;],
tcl_cv_type_fd_set=yes, tcl_cv_type_fd_set=no)])
tcl_ok=$tcl_cv_type_fd_set
if test $tcl_ok = no; then
AC_CACHE_CHECK([for fd_mask in sys/select], tcl_cv_grep_fd_mask, [
AC_EGREP_HEADER(fd_mask, sys/select.h,
tcl_cv_grep_fd_mask=present, tcl_cv_grep_fd_mask=missing)])
if test $tcl_cv_grep_fd_mask = present; then
AC_DEFINE(HAVE_SYS_SELECT_H)
tcl_ok=yes
fi
fi
if test $tcl_ok = no; then
AC_DEFINE(NO_FD_SET)
fi
#------------------------------------------------------------------------------
# Find out all about time handling differences.
#------------------------------------------------------------------------------
|
| ︙ | ︙ | |||
179 180 181 182 183 184 185 | #-------------------------------------------------------------------- AC_CHECK_FUNC(memmove, , [AC_DEFINE(NO_MEMMOVE) AC_DEFINE(NO_STRING_H)]) #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even # even if the original string is empty. #-------------------------------------------------------------------- | | > | | | | | | < | > | < < < | > > > | | | | | | | | | | | | > > > | > > | < > > | | | | | | | | | | | | > > > | > > | < | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
#--------------------------------------------------------------------
AC_CHECK_FUNC(memmove, , [AC_DEFINE(NO_MEMMOVE) AC_DEFINE(NO_STRING_H)])
#--------------------------------------------------------------------
# On some systems strstr is broken: it returns a pointer even
# even if the original string is empty.
#--------------------------------------------------------------------
dnl only run if AC_REPLACE_FUNCS(strstr) hasn't already added strstr.o
if test "x${ac_cv_func_strstr}" = "xyes"; then
AC_CACHE_CHECK([proper strstr implementation], tcl_cv_strstr_unbroken, [
AC_TRY_RUN([
extern int strstr();
int main()
{
exit(strstr("\0test", "test") ? 1 : 0);
}], tcl_cv_strstr_unbroken=ok, tcl_cv_strstr_unbroken=broken,
tcl_cv_strstr_unbroken=broken)])
if test $tcl_cv_strstr_unbroken = broken; then
LIBOBJS="$LIBOBJS strstr.o"
fi
fi
#--------------------------------------------------------------------
# Check for strtoul function. This is tricky because under some
# versions of AIX strtoul returns an incorrect terminator
# pointer for the string "0".
#--------------------------------------------------------------------
AC_CHECK_FUNC(strtoul, tcl_ok=1, tcl_ok=0)
if test $tcl_ok = 1; then
AC_CACHE_CHECK([proper strtoul implementation], tcl_cv_strtoul_unbroken, [
AC_TRY_RUN([
extern int strtoul();
int main()
{
char *string = "0";
char *term;
int value;
value = strtoul(string, &term, 0);
if ((value != 0) || (term != (string+1))) {
exit(1);
}
exit(0);
}], tcl_cv_strtoul_unbroken=ok , tcl_cv_strtoul_unbroken=broken,
tcl_cv_strtoul_unbroken=broken)])
if test $tcl_cv_strtoul_unbroken = broken; then
tcl_ok=0
fi
fi
if test $tcl_ok = 0; then
LIBOBJS="$LIBOBJS strtoul.o"
fi
#--------------------------------------------------------------------
# Check for the strtod function. This is tricky because in some
# versions of Linux strtod mis-parses strings starting with "+".
#--------------------------------------------------------------------
AC_CHECK_FUNC(strtod, tcl_ok=1, tcl_ok=0)
if test $tcl_ok = 1; then
AC_CACHE_CHECK([proper strtod implementation], tcl_cv_strtod_unbroken, [
AC_TRY_RUN([
extern double strtod();
int main()
{
char *string = " +69";
char *term;
double value;
value = strtod(string, &term);
if ((value != 69) || (term != (string+4))) {
exit(1);
}
exit(0);
}], tcl_cv_strtod_unbroken=ok , tcl_cv_strtod_unbroken=broken,
tcl_cv_strtod_unbroken=broken)])
if test $tcl_cv_strtod_unbroken = broken; then
tcl_ok=0
fi
fi
if test $tcl_ok = 0; then
LIBOBJS="$LIBOBJS strtod.o"
fi
#--------------------------------------------------------------------
# Under Solaris 2.4, strtod returns the wrong value for the
# terminating character under some conditions. Check for this
# and if the problem exists use a substitute procedure
|
| ︙ | ︙ | |||
263 264 265 266 267 268 269 | #-------------------------------------------------------------------- AC_TYPE_MODE_T AC_TYPE_PID_T AC_TYPE_SIZE_T AC_TYPE_UID_T | | | < | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
#--------------------------------------------------------------------
AC_TYPE_MODE_T
AC_TYPE_PID_T
AC_TYPE_SIZE_T
AC_TYPE_UID_T
AC_CACHE_CHECK([for socklen_t], ac_cv_type_socklen_t, [
AC_EGREP_CPP(changequote(<<,>>)dnl
<<(^|[^a-zA-Z_0-9])socklen_t[^a-zA-Z_0-9]>>dnl
changequote([,]),[
#include <sys/types.h>
#include <sys/socket.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
], ac_cv_type_socklen_t=yes, ac_cv_type_socklen_t=no)])
if test $ac_cv_type_socklen_t = no; then
AC_DEFINE(socklen_t, unsigned)
fi
#--------------------------------------------------------------------
# If a system doesn't have an opendir function (man, that's old!)
# then we have to supply a different version of dirent.h which
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 | # The check below checks whether <sys/wait.h> defines the type # "union wait" correctly. It's needed because of weirdness in # HP-UX where "union wait" is defined in both the BSD and SYS-V # environments. Checking the usability of WIFEXITED seems to do # the trick. #-------------------------------------------------------------------- | < | | < | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 |
# The check below checks whether <sys/wait.h> defines the type
# "union wait" correctly. It's needed because of weirdness in
# HP-UX where "union wait" is defined in both the BSD and SYS-V
# environments. Checking the usability of WIFEXITED seems to do
# the trick.
#--------------------------------------------------------------------
AC_CACHE_CHECK([union wait], tcl_cv_union_wait, [
AC_TRY_LINK([#include <sys/types.h>
#include <sys/wait.h>], [
union wait x;
WIFEXITED(x); /* Generates compiler error if WIFEXITED
* uses an int. */
], tcl_cv_union_wait=yes, tcl_cv_union_wait=no)])
if test $tcl_cv_union_wait = no; then
AC_DEFINE(NO_UNION_WAIT)
fi
#--------------------------------------------------------------------
# Check whether there is an strncasecmp function on this system.
# This is a bit tricky because under SCO it's in -lsocket and
|
| ︙ | ︙ | |||
341 342 343 344 345 346 347 |
# declare it.
#--------------------------------------------------------------------
AC_CHECK_FUNC(BSDgettimeofday,
[AC_DEFINE(HAVE_BSDGETTIMEOFDAY)], [
AC_CHECK_FUNC(gettimeofday, , [AC_DEFINE(NO_GETTOD)])
])
| | < | < | < | < | < | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 |
# declare it.
#--------------------------------------------------------------------
AC_CHECK_FUNC(BSDgettimeofday,
[AC_DEFINE(HAVE_BSDGETTIMEOFDAY)], [
AC_CHECK_FUNC(gettimeofday, , [AC_DEFINE(NO_GETTOD)])
])
AC_CACHE_CHECK([for gettimeofday declaration], tcl_cv_grep_gettimeofday, [
AC_EGREP_HEADER(gettimeofday, sys/time.h,
tcl_cv_grep_gettimeofday=present, tcl_cv_grep_gettimeofday=missing)])
if test $tcl_cv_grep_gettimeofday = missing ; then
AC_DEFINE(GETTOD_NOT_DECLARED)
fi
#--------------------------------------------------------------------
# The following code checks to see whether it is possible to get
# signed chars on this platform. This is needed in order to
# properly generate sign-extended ints from character values.
#--------------------------------------------------------------------
AC_C_CHAR_UNSIGNED
AC_CACHE_CHECK([signed char declarations], tcl_cv_char_signed, [
AC_TRY_COMPILE(, [
signed char *p;
p = 0;
], tcl_cv_char_signed=yes, tcl_cv_char_signed=no)])
if test $tcl_cv_char_signed = yes; then
AC_DEFINE(HAVE_SIGNED_CHAR)
fi
#--------------------------------------------------------------------
# Does putenv() copy or not? We need to know to avoid memory leaks.
#--------------------------------------------------------------------
AC_CACHE_CHECK([for a putenv() that copies the buffer], tcl_cv_putenv_copy, [
AC_TRY_RUN([
#include <stdlib.h>
#define OURVAR "havecopy=yes"
int main (int argc, char *argv[])
{
char *foo, *bar;
foo = (char *)strdup(OURVAR);
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 |
/* does copy */
return 1;
}
}
],
tcl_cv_putenv_copy=no,
tcl_cv_putenv_copy=yes,
| | < < | > > | | > > | | > > > | | > > | > > > > > > > > > > > > > > > > < < < > > | | < | > > > > > > > | > < < > > > > > > > > > > > > > > | | < | | < > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | > | > | | > | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
/* does copy */
return 1;
}
}
],
tcl_cv_putenv_copy=no,
tcl_cv_putenv_copy=yes,
tcl_cv_putenv_copy=no)])
if test $tcl_cv_putenv_copy = yes; then
AC_DEFINE(HAVE_PUTENV_THAT_COPIES)
fi
#--------------------------------------------------------------------
# Check for support of nl_langinfo function
#--------------------------------------------------------------------
SC_ENABLE_LANGINFO
#--------------------------------------------------------------------
# Darwin specific API checks and defines
#--------------------------------------------------------------------
if test "`uname -s`" = "Darwin" ; then
AC_CHECK_HEADERS(copyfile.h)
AC_CHECK_FUNCS(copyfile)
if test $tcl_corefoundation = yes; then
AC_CHECK_HEADERS(libkern/OSAtomic.h)
AC_CHECK_FUNCS(OSSpinLockLock)
AC_CHECK_FUNCS(pthread_atfork)
fi
AC_DEFINE(USE_VFORK)
AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8")
AC_DEFINE(TCL_LOAD_FROM_MEMORY)
AC_CHECK_HEADERS(AvailabilityMacros.h)
if test "$ac_cv_header_AvailabilityMacros_h" = yes; then
AC_CACHE_CHECK([if weak import is available], tcl_cv_cc_weak_import, [
hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
AC_TRY_LINK([
#ifdef __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__
#if __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020
#error __ENVIRONMENT_MAC_OS_X_VERSION_MIN_REQUIRED__ < 1020
#endif
#elif MAC_OS_X_VERSION_MIN_REQUIRED < 1020
#error MAC_OS_X_VERSION_MIN_REQUIRED < 1020
#endif
int rand(void) __attribute__((weak_import));
], [rand();],
tcl_cv_cc_weak_import=yes, tcl_cv_cc_weak_import=no)
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_weak_import = yes; then
AC_DEFINE(HAVE_WEAK_IMPORT)
fi
fi
fi
#--------------------------------------------------------------------
# Check for support of fts functions (readdir replacement)
#--------------------------------------------------------------------
AC_CACHE_CHECK([for fts], tcl_cv_api_fts, [
AC_TRY_LINK([
#include <sys/param.h>
#include <sys/stat.h>
#include <fts.h>
], [
char*const p[2] = {"/", NULL};
FTS *f = fts_open(p, FTS_PHYSICAL|FTS_NOCHDIR|FTS_NOSTAT, NULL);
FTSENT *e = fts_read(f); fts_close(f);
], tcl_cv_api_fts=yes, tcl_cv_api_fts=no)])
if test $tcl_cv_api_fts = yes; then
AC_DEFINE(HAVE_FTS)
fi
#--------------------------------------------------------------------
# The statements below check for systems where POSIX-style
# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented.
# On these systems (mostly older ones), use the old BSD-style
# FIONBIO approach instead.
#--------------------------------------------------------------------
SC_BLOCKING_STYLE
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------
TCL_UNSHARED_LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
TCL_SHARED_LIB_SUFFIX=${SHARED_LIB_SUFFIX}
eval "TCL_LIB_FILE=libtcl${LIB_SUFFIX}"
# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# so that the backslashes quoting the DBX braces are dropped.
# Trick to replace DBGX with TCL_DBGX
DBGX='${TCL_DBGX}'
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"
TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)'
PRIVATE_INCLUDE_DIR='$(includedir)'
HTML_DIR='$(DISTDIR)/html'
# Note: in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..": this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.
if test "`uname -s`" = "Darwin" ; then
SC_ENABLE_FRAMEWORK
TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`"
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name ${DYLIB_INSTALL_DIR}/${TCL_LIB_FILE} -seg1addr 0xa000000'
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist'
EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist'
tcl_config_files="${tcl_config_files} [Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in]"
fi
if test "$FRAMEWORK_BUILD" = "1" ; then
AC_DEFINE(TCL_FRAMEWORK)
# Construct a fake local framework structure to make linking with
# '-framework Tcl' and running of tcltest work
AC_OUTPUT_COMMANDS([test "$FRAMEWORK_BUILD" = "1" && n=Tcl &&
f=$n.framework && v=Versions/$VERSION &&
echo "creating $f" && rm -rf $f && mkdir -p $f/$v/Resources &&
ln -s $v/$n $v/Resources $f && ln -s ../../../$n $f/$v &&
ln -s ../../../../$n-Info.plist $f/$v/Resources/Info.plist &&
unset n f v
], [VERSION=${TCL_VERSION} FRAMEWORK_BUILD=${FRAMEWORK_BUILD}])
LD_LIBRARY_PATH_VAR="DYLD_FRAMEWORK_PATH"
if test "${libdir}" = '${exec_prefix}/lib'; then
# override libdir default
libdir="/Library/Frameworks"
fi
TCL_LIB_FILE="Tcl"
TCL_LIB_FLAG="-framework Tcl"
TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm $(HTML_INSTALL_DIR)/TclTOC.html'
EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources" && mkdir -p "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
TCL_YEAR="`date +%Y`"
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
# can pick up a potential make override of VERSION. Also, don't put this
# into CFLAGS as it should not go into tclConfig.sh
EXTRA_CC_SWITCHES='-DTCL_FRAMEWORK_VERSION=\"$(VERSION)\"'
else
# libdir must be a fully qualified path and not ${exec_prefix}/lib
eval libdir="$libdir"
if test "$SHARED_BUILD" = "0" || test "$TCL_NEEDS_EXP_FILE" = "0"; then
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_LIB_FLAG="-ltcl${TCL_VERSION}\${TCL_DBGX}"
else
TCL_LIB_FLAG="-ltcl`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
fi
TCL_BUILD_LIB_SPEC="-L`pwd` ${TCL_LIB_FLAG}"
TCL_LIB_SPEC="-L${libdir} ${TCL_LIB_FLAG}"
else
TCL_BUILD_EXP_FILE="lib.exp"
eval "TCL_EXP_FILE=libtcl${TCL_EXPORT_FILE_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_EXP_FILE=\"${TCL_EXP_FILE}\""
if test "$GCC" = "yes" ; then
TCL_BUILD_LIB_SPEC="-Wl,-bI:`pwd`/${TCL_BUILD_EXP_FILE} -L`pwd`"
TCL_LIB_SPEC="-Wl,-bI:${libdir}/${TCL_EXP_FILE} -L`pwd`"
else
TCL_BUILD_LIB_SPEC="-bI:`pwd`/${TCL_BUILD_EXP_FILE}"
TCL_LIB_SPEC="-bI:${libdir}/${TCL_EXP_FILE}"
fi
fi
fi
VERSION='${VERSION}'
eval "CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX}"
eval "CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX}"
eval "CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX}"
VERSION=${TCL_VERSION}
#--------------------------------------------------------------------
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$FRAMEWORK_BUILD" = "1" ; then
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl /Network/Library/Tcl /System/Library/Tcl ~/Library/Frameworks /Library/Frameworks /Network/Library/Frameworks /System/Library/Frameworks"
elif test "$prefix" != "$exec_prefix"; then
TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
TCL_PACKAGE_PATH="${prefix}/lib"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
# stub support.
#--------------------------------------------------------------------
# Replace ${VERSION} with contents of ${TCL_VERSION}
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
# Replace DBGX with TCL_DBGX
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_DIR=${libdir}"
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}\${TCL_DBGX}"
else
TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`\${TCL_DBGX}"
fi
TCL_BUILD_STUB_LIB_SPEC="-L`pwd` ${TCL_STUB_LIB_FLAG}"
TCL_STUB_LIB_SPEC="-L${TCL_STUB_LIB_DIR} ${TCL_STUB_LIB_FLAG}"
TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
TCL_STUB_LIB_PATH="${TCL_STUB_LIB_DIR}/${TCL_STUB_LIB_FILE}"
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
#------------------------------------------------------------------------
# tclConfig.sh refers to this by a different name
#------------------------------------------------------------------------
TCL_SHARED_BUILD=${SHARED_BUILD}
AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_MAJOR_VERSION)
AC_SUBST(TCL_MINOR_VERSION)
AC_SUBST(TCL_PATCH_LEVEL)
AC_SUBST(TCL_YEAR)
AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
AC_SUBST(TCL_LIB_SPEC)
AC_SUBST(TCL_STUB_LIB_FILE)
AC_SUBST(TCL_STUB_LIB_FLAG)
AC_SUBST(TCL_STUB_LIB_SPEC)
|
| ︙ | ︙ | |||
581 582 583 584 585 586 587 | AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) AC_SUBST(TCL_HAS_LONGLONG) AC_SUBST(BUILD_DLTEST) AC_SUBST(TCL_PACKAGE_PATH) | > > > > > > > > > > > > | > | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
AC_SUBST(TCL_UNSHARED_LIB_SUFFIX)
AC_SUBST(TCL_HAS_LONGLONG)
AC_SUBST(BUILD_DLTEST)
AC_SUBST(TCL_PACKAGE_PATH)
AC_SUBST(TCL_LIBRARY)
AC_SUBST(PRIVATE_INCLUDE_DIR)
AC_SUBST(HTML_DIR)
AC_SUBST(EXTRA_CC_SWITCHES)
AC_SUBST(EXTRA_INSTALL)
AC_SUBST(EXTRA_INSTALL_BINARIES)
AC_SUBST(EXTRA_BUILD_HTML)
AC_SUBST(EXTRA_TCLSH_LIBS)
SC_OUTPUT_COMMANDS_PRE
tcl_config_files="${tcl_config_files} [Makefile dltest/Makefile tclConfig.sh]"
AC_OUTPUT([${tcl_config_files}])
|
Changes to unix/dltest/Makefile.in.
1 2 3 | # This Makefile is used to create several test cases for Tcl's load # command. It also illustrates how to take advantage of configuration # exported by Tcl to set up Makefiles for shared libraries. | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # This Makefile is used to create several test cases for Tcl's load # command. It also illustrates how to take advantage of configuration # exported by Tcl to set up Makefiles for shared libraries. # RCS: @(#) $Id: Makefile.in,v 1.11.2.2 2004/09/23 20:04:07 mdejong Exp $ TCL_DBGX = @TCL_DBGX@ CC = @CC@ LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @DL_LIBS@ @LIBS@ @MATH_LIBS@ AC_FLAGS = @DEFS@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_LD = @SHLIB_LD@ SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ SRC_DIR = @srcdir@ TCL_VERSION= @TCL_VERSION@ |
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o ${SHLIB_LD_LIBS}
pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c
${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${SHLIB_LD_LIBS}
clean:
| | > > > > | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
${SHLIB_LD} -o pkgd${SHLIB_SUFFIX} pkgd.o ${SHLIB_LD_LIBS}
pkge${SHLIB_SUFFIX}: $(SRC_DIR)/pkge.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkge.c
${SHLIB_LD} -o pkge${SHLIB_SUFFIX} pkge.o ${SHLIB_LD_LIBS}
clean:
rm -f *.o config.cache config.log config.status
rm -f lib.exp ../dltest.marker
@if test "$(SHLIB_SUFFIX)" != ""; then \
echo "rm -f *${SHLIB_SUFFIX}" ; \
rm -f *${SHLIB_SUFFIX} ; \
fi
distclean: clean
rm -f Makefile
|
Changes to unix/dltest/pkga.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * pkga.c -- * * This file contains a simple Tcl package "pkga" that is intended * for testing the Tcl dynamic loading facilities. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * pkga.c -- * * This file contains a simple Tcl package "pkga" that is intended * for testing the Tcl dynamic loading facilities. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: pkga.c,v 1.4.24.3 2004/06/08 20:25:45 dgp Exp $ */ #include "tcl.h" /* * Prototypes for procedures defined later in this file: */ |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 |
Pkga_EqObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj * CONST objv[]; /* Argument objects. */
{
int result;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
return TCL_ERROR;
}
| > > > > > > > | > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
Pkga_EqObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj * CONST objv[]; /* Argument objects. */
{
int result;
CONST char *str1, *str2;
int len1, len2;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string1 string2");
return TCL_ERROR;
}
str1 = Tcl_GetStringFromObj(objv[1], &len1);
str2 = Tcl_GetStringFromObj(objv[2], &len2);
if (len1 == len2) {
result = (Tcl_UtfNcmp(str1, str2, len1) == 0);
} else {
result = 0;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(result));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Added unix/installManPage.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
#!/bin/sh
ZIP=:
while true; do
case $1 in
-s | --symlinks ) S="-s ";;
-z | --compress ) ZIP=$2; shift ;;
-e | --extension ) Z=$2; shift ;;
-s | --suffix ) SUFFIX=$2; shift ;;
*) break ;;
esac
shift
done
if test "$#" != 2; then
echo "Usage: installManPages <options> file dir"
exit 1
fi
MANPAGE=$1
DIR=$2
test -z "$S" && S="$DIR/"
# A sed script to parse the alternative names out of a man page.
#
# /^\\.SH NAME/{ ;# Look for a line, that starts with .SH NAME
# s/^.*$// ;# Delete the content of this line from the buffer
# n ;# Read next line
# s/,//g ;# Remove all commas ...
# s/\\\ //g ;# .. and backslash-escaped spaces.
# s/ \\\-.*// ;# Delete from \- to the end of line
# p ;# print the result
# q ;# exit
# }
#
# Backslashes are trippled in the sed script, because it is in
# backticks which don't pass backslashes literally.
#
# Please keep the commented version above updated if you
# change anything to the script below.
NAMES=`sed -n '
/^\\.SH NAME/{
s/^.*$//
n
s/,//g
s/\\\ //g
s/ \\\-.*//
p
q
}' $MANPAGE`
SECTION=`echo $MANPAGE | sed 's/.*\(.\)$/\1/'`
SRCDIR=`dirname $MANPAGE`
FIRST=""
for f in $NAMES; do
f=$f.$SECTION$SUFFIX
if test -z "$FIRST" ; then
FIRST=$f
rm -f $DIR/$FIRST $DIR/$FIRST.*
sed -e "/man\.macros/r $SRCDIR/man.macros" -e "/man\.macros/d" \
$MANPAGE > $DIR/$FIRST
chmod 444 $DIR/$FIRST
$ZIP $DIR/$FIRST
else
rm -f $DIR/$f $DIR/$f.*
ln $S$FIRST$Z $DIR/$f$Z
fi
done
|
Deleted unix/mkLinks.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted unix/mkLinks.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to unix/tcl.m4.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | # --with-tcl=... # # Defines the following vars: # TCL_BIN_DIR Full path to the directory containing # the tclConfig.sh file #------------------------------------------------------------------------ | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# --with-tcl=...
#
# Defines the following vars:
# TCL_BIN_DIR Full path to the directory containing
# the tclConfig.sh file
#------------------------------------------------------------------------
AC_DEFUN([SC_PATH_TCLCONFIG], [
#
# Ok, lets find the tcl configuration
# First, look for one uninstalled.
# the alternative search directory is invoked by --with-tcl
#
if test x"${no_tcl}" = x ; then
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
fi
fi
# then check for a private Tcl installation
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in \
../tcl \
`ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
../../tcl \
`ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
../../../tcl \
`ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/unix/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd $i/unix; pwd)`
break
fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
; do
if test -f "$i/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd $i; pwd)`
break
fi
done
fi
# check in a few other private locations
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in \
${srcdir}/../tcl \
`ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/unix/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd $i/unix; pwd)`
break
fi
done
fi
])
if test x"${ac_cv_c_tclconfig}" = x ; then
TCL_BIN_DIR="# no Tcl configs found"
| > > > > > > > > > > > > > > > > > > > > > > > > | | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
fi
fi
# then check for a private Tcl installation
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in \
../tcl \
`ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
../../tcl \
`ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \
../../../tcl \
`ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/unix/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd $i/unix; pwd)`
break
fi
done
fi
# on Darwin, check in Framework installation locations
if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then
for i in `ls -d ~/Library/Frameworks 2>/dev/null` \
`ls -d /Library/Frameworks 2>/dev/null` \
`ls -d /Network/Library/Frameworks 2>/dev/null` \
`ls -d /System/Library/Frameworks 2>/dev/null` \
; do
if test -f "$i/Tcl.framework/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd $i/Tcl.framework; pwd)`
break
fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
; do
if test -f "$i/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd $i; pwd)`
break
fi
done
fi
# check in a few other private locations
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in \
${srcdir}/../tcl \
`ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/unix/tclConfig.sh" ; then
ac_cv_c_tclconfig=`(cd $i/unix; pwd)`
break
fi
done
fi
])
if test x"${ac_cv_c_tclconfig}" = x ; then
TCL_BIN_DIR="# no Tcl configs found"
AC_MSG_WARN([Can't find Tcl configuration definitions])
exit 0
else
no_tcl=
TCL_BIN_DIR=${ac_cv_c_tclconfig}
AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh])
fi
fi
])
#------------------------------------------------------------------------
# SC_PATH_TKCONFIG --
#
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 | # --with-tk=... # # Defines the following vars: # TK_BIN_DIR Full path to the directory containing # the tkConfig.sh file #------------------------------------------------------------------------ | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
# --with-tk=...
#
# Defines the following vars:
# TK_BIN_DIR Full path to the directory containing
# the tkConfig.sh file
#------------------------------------------------------------------------
AC_DEFUN([SC_PATH_TKCONFIG], [
#
# Ok, lets find the tk configuration
# First, look for one uninstalled.
# the alternative search directory is invoked by --with-tk
#
if test x"${no_tk}" = x ; then
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
fi
fi
# then check for a private Tk library
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in \
../tk \
`ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \
../../tk \
`ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \
../../../tk \
`ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/unix/tkConfig.sh" ; then
ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
break
fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
; do
if test -f "$i/tkConfig.sh" ; then
ac_cv_c_tkconfig=`(cd $i; pwd)`
break
fi
done
fi
# check in a few other private locations
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in \
${srcdir}/../tk \
`ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/unix/tkConfig.sh" ; then
ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
break
fi
done
fi
])
if test x"${ac_cv_c_tkconfig}" = x ; then
TK_BIN_DIR="# no Tk configs found"
| > > > > > > > > > > > > > > > > > > > > > > > > > > | | < | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 |
fi
fi
# then check for a private Tk library
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in \
../tk \
`ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \
../../tk \
`ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \
../../../tk \
`ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/unix/tkConfig.sh" ; then
ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
break
fi
done
fi
# on Darwin, check in Framework installation locations
if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tkconfig}" = x ; then
for i in `ls -d ~/Library/Frameworks 2>/dev/null` \
`ls -d /Library/Frameworks 2>/dev/null` \
`ls -d /Network/Library/Frameworks 2>/dev/null` \
`ls -d /System/Library/Frameworks 2>/dev/null` \
; do
if test -f "$i/Tk.framework/tkConfig.sh" ; then
ac_cv_c_tkconfig=`(cd $i/Tk.framework; pwd)`
break
fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
; do
if test -f "$i/tkConfig.sh" ; then
ac_cv_c_tkconfig=`(cd $i; pwd)`
break
fi
done
fi
# check in a few other private locations
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in \
${srcdir}/../tk \
`ls -dr ${srcdir}/../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \
`ls -dr ${srcdir}/../tk[[8-9]].[[0-9]] 2>/dev/null` \
`ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do
if test -f "$i/unix/tkConfig.sh" ; then
ac_cv_c_tkconfig=`(cd $i/unix; pwd)`
break
fi
done
fi
])
if test x"${ac_cv_c_tkconfig}" = x ; then
TK_BIN_DIR="# no Tk configs found"
AC_MSG_WARN([Can't find Tk configuration definitions])
exit 0
else
no_tk=
TK_BIN_DIR=${ac_cv_c_tkconfig}
AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh])
fi
fi
])
#------------------------------------------------------------------------
# SC_LOAD_TCLCONFIG --
#
# Load the tclConfig.sh file
#
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | # Subst the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE # #------------------------------------------------------------------------ | | | | | | > > > | < < | > > > > > > > > > > > > | | > > > > > > > > | < < < < < > | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
# Subst the following vars:
# TCL_BIN_DIR
# TCL_SRC_DIR
# TCL_LIB_FILE
#
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TCLCONFIG], [
AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh])
if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
AC_MSG_RESULT([loading])
. ${TCL_BIN_DIR}/tclConfig.sh
else
AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh])
fi
# eval is required to do the TCL_DBGX substitution
eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\""
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
# If the TCL_BIN_DIR is the build directory (not the install directory),
# then set the common variable name to the value of the build variables.
# For example, the variable TCL_LIB_SPEC will be set to the value
# of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC
# instead of TCL_BUILD_LIB_SPEC since it will work with both an
# installed and uninstalled version of Tcl.
if test -f ${TCL_BIN_DIR}/Makefile ; then
TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC}
TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC}
TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH}
elif test "`uname -s`" = "Darwin"; then
# If Tcl was built as a framework, attempt to use the libraries
# from the framework at the given location so that linking works
# against Tcl.framework installed in an arbitary location.
case ${TCL_DEFS} in
*TCL_FRAMEWORK*)
if test -f ${TCL_BIN_DIR}/${TCL_LIB_FILE}; then
for i in "`cd ${TCL_BIN_DIR}; pwd`" \
"`cd ${TCL_BIN_DIR}/../..; pwd`"; do
if test "`basename "$i"`" = "${TCL_LIB_FILE}.framework"; then
TCL_LIB_SPEC="-F`dirname "$i"` -framework ${TCL_LIB_FILE}"
break
fi
done
fi
if test -f ${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}; then
TCL_STUB_LIB_SPEC="-L${TCL_BIN_DIR} ${TCL_STUB_LIB_FLAG}"
TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}"
fi
;;
esac
fi
# eval is required to do the TCL_DBGX substitution
eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\""
eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\""
eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\""
AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_PATCH_LEVEL)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
AC_SUBST(TCL_LIB_SPEC)
|
| ︙ | ︙ | |||
270 271 272 273 274 275 276 | # # Results: # # Sets the following vars that should be in tkConfig.sh: # TK_BIN_DIR #------------------------------------------------------------------------ | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 |
#
# Results:
#
# Sets the following vars that should be in tkConfig.sh:
# TK_BIN_DIR
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TKCONFIG], [
AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh])
if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then
AC_MSG_RESULT([loading])
. ${TK_BIN_DIR}/tkConfig.sh
else
AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh])
fi
# eval is required to do the TK_DBGX substitution
eval "TK_LIB_FILE=\"${TK_LIB_FILE}\""
eval "TK_STUB_LIB_FILE=\"${TK_STUB_LIB_FILE}\""
# If the TK_BIN_DIR is the build directory (not the install directory),
# then set the common variable name to the value of the build variables.
# For example, the variable TK_LIB_SPEC will be set to the value
# of TK_BUILD_LIB_SPEC. An extension should make use of TK_LIB_SPEC
# instead of TK_BUILD_LIB_SPEC since it will work with both an
# installed and uninstalled version of Tcl.
if test -f ${TK_BIN_DIR}/Makefile ; then
TK_LIB_SPEC=${TK_BUILD_LIB_SPEC}
TK_STUB_LIB_SPEC=${TK_BUILD_STUB_LIB_SPEC}
TK_STUB_LIB_PATH=${TK_BUILD_STUB_LIB_PATH}
elif test "`uname -s`" = "Darwin"; then
# If Tk was built as a framework, attempt to use the libraries
# from the framework at the given location so that linking works
# against Tk.framework installed in an arbitary location.
case ${TK_DEFS} in
*TK_FRAMEWORK*)
if test -f ${TK_BIN_DIR}/${TK_LIB_FILE}; then
for i in "`cd ${TK_BIN_DIR}; pwd`" \
"`cd ${TK_BIN_DIR}/../..; pwd`"; do
if test "`basename "$i"`" = "${TK_LIB_FILE}.framework"; then
TK_LIB_SPEC="-F`dirname "$i"` -framework ${TK_LIB_FILE}"
break
fi
done
fi
if test -f ${TK_BIN_DIR}/${TK_STUB_LIB_FILE}; then
TK_STUB_LIB_SPEC="-L${TK_BIN_DIR} ${TK_STUB_LIB_FLAG}"
TK_STUB_LIB_PATH="${TK_BIN_DIR}/${TK_STUB_LIB_FILE}"
fi
;;
esac
fi
# eval is required to do the TK_DBGX substitution
eval "TK_LIB_FLAG=\"${TK_LIB_FLAG}\""
eval "TK_LIB_SPEC=\"${TK_LIB_SPEC}\""
eval "TK_STUB_LIB_FLAG=\"${TK_STUB_LIB_FLAG}\""
eval "TK_STUB_LIB_SPEC=\"${TK_STUB_LIB_SPEC}\""
AC_SUBST(TK_VERSION)
AC_SUBST(TK_BIN_DIR)
AC_SUBST(TK_SRC_DIR)
AC_SUBST(TK_LIB_FILE)
AC_SUBST(TK_LIB_FLAG)
AC_SUBST(TK_LIB_SPEC)
AC_SUBST(TK_STUB_LIB_FILE)
AC_SUBST(TK_STUB_LIB_FLAG)
AC_SUBST(TK_STUB_LIB_SPEC)
])
#------------------------------------------------------------------------
# SC_PROG_TCLSH
# Locate a tclsh shell installed on the system path. This macro
# will only find a Tcl shell that already exists on the system.
# It will not find a Tcl shell in the Tcl build directory or
# a Tcl shell that has been installed from the Tcl build directory.
# If a Tcl shell can't be located on the PATH, then TCLSH_PROG will
# be set to "". Extensions should take care not to create Makefile
# rules that are run by default and depend on TCLSH_PROG. An
# extension can't assume that an executable Tcl shell exists at
# build time.
#
# Arguments
# none
#
# Results
# Subst's the following values:
# TCLSH_PROG
#------------------------------------------------------------------------
AC_DEFUN([SC_PROG_TCLSH], [
AC_MSG_CHECKING([for tclsh])
AC_CACHE_VAL(ac_cv_path_tclsh, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/tclsh[[8-9]]* 2> /dev/null` \
`ls -r $dir/tclsh* 2> /dev/null` ; do
if test x"$ac_cv_path_tclsh" = x ; then
if test -f "$j" ; then
ac_cv_path_tclsh=$j
break
fi
fi
done
done
])
if test -f "$ac_cv_path_tclsh" ; then
TCLSH_PROG="$ac_cv_path_tclsh"
AC_MSG_RESULT([$TCLSH_PROG])
else
# It is not an error if an installed version of Tcl can't be located.
TCLSH_PROG=""
AC_MSG_RESULT([No tclsh found on PATH])
fi
AC_SUBST(TCLSH_PROG)
])
#------------------------------------------------------------------------
# SC_BUILD_TCLSH
# Determine the fully qualified path name of the tclsh executable
# in the Tcl build directory. This macro will correctly determine
# the name of the tclsh executable even if tclsh has not yet
# been built in the build directory. The build tclsh must be used
# when running tests from an extension build directory. It is not
# correct to use the TCLSH_PROG in cases like this.
#
# Arguments
# none
#
# Results
# Subst's the following values:
# BUILD_TCLSH
#------------------------------------------------------------------------
AC_DEFUN([SC_BUILD_TCLSH], [
AC_MSG_CHECKING([for tclsh in Tcl build directory])
BUILD_TCLSH=${TCL_BIN_DIR}/tclsh
AC_MSG_RESULT([$BUILD_TCLSH])
AC_SUBST(BUILD_TCLSH)
])
#------------------------------------------------------------------------
# SC_ENABLE_SHARED --
#
# Allows the building of shared libraries
#
|
| ︙ | ︙ | |||
307 308 309 310 311 312 313 | # STATIC_BUILD Used for building import/export libraries # on Windows. # # Sets the following vars: # SHARED_BUILD Value of 1 or 0 #------------------------------------------------------------------------ | | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
# STATIC_BUILD Used for building import/export libraries
# on Windows.
#
# Sets the following vars:
# SHARED_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SHARED], [
AC_MSG_CHECKING([how to build libraries])
AC_ARG_ENABLE(shared,
[ --enable-shared build and link with shared libraries [--enable-shared]],
[tcl_ok=$enableval], [tcl_ok=yes])
if test "${enable_shared+set}" = set; then
enableval="$enable_shared"
|
| ︙ | ︙ | |||
347 348 349 350 351 352 353 | # Adds the following arguments to configure: # --enable-framework=yes|no # # Sets the following vars: # FRAMEWORK_BUILD Value of 1 or 0 #------------------------------------------------------------------------ | | > | | | | | | > | > | < > | | | | | | > | | < < | | > | | > | > > | < > > > > | < < > > > | > | > | > | | > | | > < > > > > > > > > > > > > | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 |
# Adds the following arguments to configure:
# --enable-framework=yes|no
#
# Sets the following vars:
# FRAMEWORK_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_FRAMEWORK], [
if test "`uname -s`" = "Darwin" ; then
AC_MSG_CHECKING([how to package libraries])
AC_ARG_ENABLE(framework,
[ --enable-framework package shared libraries in MacOSX frameworks [--disable-framework]],
[enable_framework=$enableval], [enable_framework=no])
if test $enable_framework = yes; then
if test $SHARED_BUILD = 0; then
AC_MSG_WARN([Frameworks can only be built if --enable-shared is yes])
enable_framework=no
fi
if test $tcl_corefoundation = no; then
AC_MSG_WARN([Frameworks can only be used when CoreFoundation is available])
enable_framework=no
fi
fi
if test $enable_framework = yes; then
AC_MSG_RESULT([framework])
FRAMEWORK_BUILD=1
else
if test $SHARED_BUILD = 1; then
AC_MSG_RESULT([shared library])
else
AC_MSG_RESULT([static library])
fi
FRAMEWORK_BUILD=0
fi
fi
])
#------------------------------------------------------------------------
# SC_ENABLE_THREADS --
#
# Specify if thread support should be enabled. TCL_THREADS is
# checked so that if you are compiling an extension against a
# threaded core, your extension must be compiled threaded as well.
#
# Arguments:
# none
#
# Results:
#
# Adds the following arguments to configure:
# --enable-threads
#
# Sets the following vars:
# THREADS_LIBS Thread library(s)
#
# Defines the following vars:
# TCL_THREADS
# _REENTRANT
# _THREAD_SAFE
#
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_THREADS], [
AC_ARG_ENABLE(threads, [ --enable-threads build with threads],
[tcl_ok=$enableval], [tcl_ok=no])
if test "${TCL_THREADS}" = 1; then
tcl_threaded_core=1;
fi
if test "$tcl_ok" = "yes" -o "${TCL_THREADS}" = 1; then
TCL_THREADS=1
# USE_THREAD_ALLOC tells us to try the special thread-based
# allocator that significantly reduces lock contention
AC_DEFINE(USE_THREAD_ALLOC)
AC_DEFINE(_REENTRANT)
if test "`uname -s`" = "SunOS" ; then
AC_DEFINE(_POSIX_PTHREAD_SEMANTICS)
fi
AC_DEFINE(_THREAD_SAFE)
AC_CHECK_LIB(pthread,pthread_mutex_init,tcl_ok=yes,tcl_ok=no)
if test "$tcl_ok" = "no"; then
# Check a little harder for __pthread_mutex_init in the same
# library, as some systems hide it there until pthread.h is
# defined. We could alternatively do an AC_TRY_COMPILE with
# pthread.h, but that will work with libpthread really doesn't
# exist, like AIX 4.2. [Bug: 4359]
AC_CHECK_LIB(pthread, __pthread_mutex_init,
tcl_ok=yes, tcl_ok=no)
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthread"
else
AC_CHECK_LIB(pthreads, pthread_mutex_init,
tcl_ok=yes, tcl_ok=no)
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthreads"
else
AC_CHECK_LIB(c, pthread_mutex_init,
tcl_ok=yes, tcl_ok=no)
if test "$tcl_ok" = "no"; then
AC_CHECK_LIB(c_r, pthread_mutex_init,
tcl_ok=yes, tcl_ok=no)
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -pthread"
else
TCL_THREADS=0
AC_MSG_WARN([Don't know how to find pthread lib on your system - you must disable thread support or edit the LIBS in the Makefile...])
fi
fi
fi
fi
# Does the pthread-implementation provide
# 'pthread_attr_setstacksize' ?
ac_saved_libs=$LIBS
LIBS="$LIBS $THREADS_LIBS"
AC_CHECK_FUNCS(pthread_attr_setstacksize)
AC_CHECK_FUNCS(pthread_atfork)
LIBS=$ac_saved_libs
else
TCL_THREADS=0
fi
# Do checking message here to not mess up interleaved configure output
AC_MSG_CHECKING([for building with threads])
if test "${TCL_THREADS}" = 1; then
AC_DEFINE(TCL_THREADS, 1, [Are we building with threads enabled?])
if test "${tcl_threaded_core}" = 1; then
AC_MSG_RESULT([yes (threaded core)])
else
AC_MSG_RESULT([yes])
fi
else
AC_MSG_RESULT([no (default)])
fi
AC_SUBST(TCL_THREADS)
])
#------------------------------------------------------------------------
# SC_ENABLE_SYMBOLS --
#
# Specify if debugging symbols should be used.
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 | # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false # DBGX Debug library extension # #------------------------------------------------------------------------ | | | 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
# Sets to $(CFLAGS_OPTIMIZE) if false
# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true
# Sets to $(LDFLAGS_OPTIMIZE) if false
# DBGX Debug library extension
#
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no])
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
DBGX=""
|
| ︙ | ︙ | |||
545 546 547 548 549 550 551 | # --enable-langinfo=yes|no (default is yes) # # Defines the following vars: # HAVE_LANGINFO Triggers use of nl_langinfo if defined. # #------------------------------------------------------------------------ | | < | < > | | | < < | < > | > | | > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | > > | > > | < | > > > > < > > > > | < < < < < > > > | | < | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
# --enable-langinfo=yes|no (default is yes)
#
# Defines the following vars:
# HAVE_LANGINFO Triggers use of nl_langinfo if defined.
#
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_LANGINFO], [
AC_ARG_ENABLE(langinfo,
[ --enable-langinfo use nl_langinfo if possible to determine
encoding at startup, otherwise use old heuristic],
[langinfo_ok=$enableval], [langinfo_ok=yes])
HAVE_LANGINFO=0
if test "$langinfo_ok" = "yes"; then
AC_CHECK_HEADER(langinfo.h,[langinfo_ok=yes],[langinfo_ok=no])
fi
AC_MSG_CHECKING([whether to use nl_langinfo])
if test "$langinfo_ok" = "yes"; then
AC_CACHE_VAL(tcl_cv_langinfo_h, [
AC_TRY_COMPILE([#include <langinfo.h>], [nl_langinfo(CODESET);],
[tcl_cv_langinfo_h=yes],[tcl_cv_langinfo_h=no])])
AC_MSG_RESULT([$tcl_cv_langinfo_h])
if test $tcl_cv_langinfo_h = yes; then
AC_DEFINE(HAVE_LANGINFO)
fi
else
AC_MSG_RESULT([$langinfo_ok])
fi
])
#--------------------------------------------------------------------
# SC_CONFIG_MANPAGES
#
# Decide whether to use symlinks for linking the manpages,
# whether to compress the manpages after installation, and
# whether to add a package name suffix to the installed
# manpages to avoidfile name clashes.
# If compression is enabled also find out what file name suffix
# the given compression program is using.
#
# Arguments:
# none
#
# Results:
#
# Adds the following arguments to configure:
# --enable-man-symlinks
# --enable-man-compression=PROG
# --enable-man-suffix[=STRING]
#
# Defines the following variable:
#
# MAN_FLAGS - The apropriate flags for installManPage
# according to the user's selection.
#
#--------------------------------------------------------------------
AC_DEFUN([SC_CONFIG_MANPAGES], [
AC_MSG_CHECKING([whether to use symlinks for manpages])
AC_ARG_ENABLE(man-symlinks,
[ --enable-man-symlinks use symlinks for the manpages],
test "$enableval" != "no" && MAN_FLAGS="$MAN_FLAGS --symlinks",
enableval="no")
AC_MSG_RESULT([$enableval])
AC_MSG_CHECKING([whether to compress the manpages])
AC_ARG_ENABLE(man-compression,
[ --enable-man-compression=PROG
compress the manpages with PROG],
[case $enableval in
yes) AC_MSG_ERROR([missing argument to --enable-man-compression]);;
no) ;;
*) MAN_FLAGS="$MAN_FLAGS --compress $enableval";;
esac],
enableval="no")
AC_MSG_RESULT([$enableval])
if test "$enableval" != "no"; then
AC_MSG_CHECKING([for compressed file suffix])
touch TeST
$enableval TeST
Z=`ls TeST* | sed 's/^....//'`
rm -f TeST*
MAN_FLAGS="$MAN_FLAGS --extension $Z"
AC_MSG_RESULT([$Z])
fi
AC_MSG_CHECKING([whether to add a package name suffix for the manpages])
AC_ARG_ENABLE(man-suffix,
[ --enable-man-suffix=STRING
use STRING as a suffix to manpage file names
(default: $1)],
[case $enableval in
yes) enableval="$1" MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
no) ;;
*) MAN_FLAGS="$MAN_FLAGS --suffix $enableval";;
esac],
enableval="no")
AC_MSG_RESULT([$enableval])
AC_SUBST(MAN_FLAGS)
])
#--------------------------------------------------------------------
# SC_CONFIG_SYSTEM
#
# Determine what the system is (some things cannot be easily checked
# on a feature-driven basis, alas). This can usually be done via the
# "uname" command, but there are a few systems, like Next, where
# this doesn't work.
#
# Arguments:
# none
#
# Results:
# Defines the following var:
#
# system - System/platform/version identification code.
#
#--------------------------------------------------------------------
AC_DEFUN([SC_CONFIG_SYSTEM], [
AC_CACHE_CHECK([system version], tcl_cv_sys_version, [
if test -f /usr/lib/NextStep/software_version; then
tcl_cv_sys_version=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
else
tcl_cv_sys_version=`uname -s`-`uname -r`
if test "$?" -ne 0 ; then
AC_MSG_WARN([can't find uname command])
tcl_cv_sys_version=unknown
else
# Special check for weird MP-RAS system (uname returns weird
# results, and the version is kept in special file).
if test -r /etc/.relid -a "X`uname -n`" = "X`uname -s`" ; then
tcl_cv_sys_version=MP-RAS-`awk '{print [$]3}' /etc/.relid`
fi
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
fi
fi
])
system=$tcl_cv_sys_version
])
#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
# Try to determine the proper flags to pass to the compiler
# for building shared libraries and other such nonsense.
|
| ︙ | ︙ | |||
657 658 659 660 661 662 663 | # STLIB_LD - Base command to use for combining object files # into a static library. # SHLIB_CFLAGS - Flags to pass to cc when compiling the components # of a shared library (may request position-independent # code, among other things). # SHLIB_LD - Base command to use for combining object files # into a shared library. | < < < | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 |
# STLIB_LD - Base command to use for combining object files
# into a static library.
# SHLIB_CFLAGS - Flags to pass to cc when compiling the components
# of a shared library (may request position-independent
# code, among other things).
# SHLIB_LD - Base command to use for combining object files
# into a shared library.
# SHLIB_LD_LIBS - Dependent libraries for the linker to scan when
# creating shared libraries. This symbol typically
# goes at the end of the "ld" commands that build
# shared libraries. The value of the symbol is
# "${LIBS}" if all of the dependent libraries should
# be specified when creating a shared library. If
# dependent libraries should not be specified (as on
|
| ︙ | ︙ | |||
705 706 707 708 709 710 711 | # The name of the built export / import file which # should be used to link to the Tcl shared library. # Empty if Tcl is unshared. # CFLAGS_DEBUG - # Flags used when running the compiler in debug mode # CFLAGS_OPTIMIZE - # Flags used when running the compiler in optimize mode | | | | < < < < | < | | > > | < < < < | < < < < < < < < < < < < | < < < < < < < < < | | > | | > > > > | < > > | < > > > > > > > > > > > > > > > > > > > > > > > | > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
# The name of the built export / import file which
# should be used to link to the Tcl shared library.
# Empty if Tcl is unshared.
# CFLAGS_DEBUG -
# Flags used when running the compiler in debug mode
# CFLAGS_OPTIMIZE -
# Flags used when running the compiler in optimize mode
# CFLAGS - Additional CFLAGS added as necessary (usually 64-bit)
#
#--------------------------------------------------------------------
AC_DEFUN([SC_CONFIG_CFLAGS], [
# Step 0.a: Enable 64 bit support?
AC_MSG_CHECKING([if 64bit support is requested])
AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)],
[do64bit=$enableval], [do64bit=no])
AC_MSG_RESULT([$do64bit])
# Step 0.b: Enable Solaris 64 bit VIS support?
AC_MSG_CHECKING([if 64bit Sparc VIS support is requested])
AC_ARG_ENABLE(64bit-vis,[ --enable-64bit-vis enable 64bit Sparc VIS support],
[do64bitVIS=$enableval], [do64bitVIS=no])
AC_MSG_RESULT([$do64bitVIS])
if test "$do64bitVIS" = "yes"; then
# Force 64bit on with VIS
do64bit=yes
fi
# Step 1: set the variable "system" to hold the name and version number
# for the system.
SC_CONFIG_SYSTEM
# Step 2: check for existence of -ldl library. This is needed because
# Linux can use either -ldl or -ldld for dynamic loading.
AC_CHECK_LIB(dl, dlopen, have_dl=yes, have_dl=no)
# Require ranlib early so we can override it in special cases below.
AC_REQUIRE([AC_PROG_RANLIB])
# Step 3: set configuration options based on system name and version.
do64bit_ok=no
LDFLAGS_ORIG="$LDFLAGS"
TCL_EXPORT_FILE_SUFFIX=""
UNSHARED_LIB_SUFFIX=""
TCL_TRIM_DOTS='`echo ${VERSION} | tr -d .`'
ECHO_VERSION='`echo ${VERSION}`'
TCL_LIB_VERSIONS_OK=ok
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE=-O
if test "$GCC" = "yes" ; then
CFLAGS_WARNING="-Wall -Wno-implicit-int -fno-strict-aliasing"
else
CFLAGS_WARNING=""
fi
TCL_NEEDS_EXP_FILE=0
TCL_BUILD_EXP_FILE=""
TCL_EXP_FILE=""
dnl FIXME: Replace AC_CHECK_PROG with AC_CHECK_TOOL once cross compiling is fixed.
dnl AC_CHECK_TOOL(AR, ar)
AC_CHECK_PROG(AR, ar, ar)
if test "${AR}" = "" ; then
AC_MSG_ERROR([Required archive tool 'ar' not found on PATH.])
fi
STLIB_LD='${AR} cr'
LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
PLAT_OBJS=""
PLAT_SRCS=""
case $system in
AIX-*)
if test "${TCL_THREADS}" = "1" -a "$GCC" != "yes" ; then
# AIX requires the _r compiler when gcc isn't being used
case "${CC}" in
*_r)
# ok ...
;;
*)
CC=${CC}_r
;;
esac
AC_MSG_RESULT([Using $CC for compiling with threads])
fi
LIBS="$LIBS -lc"
SHLIB_CFLAGS=""
# Note: need the LIBS below, otherwise Tk won't find Tcl's
# symbols when dynamically loaded into tclsh.
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
LD_LIBRARY_PATH_VAR="LIBPATH"
# Check to enable 64-bit flags for compiler/linker on AIX 4+
if test "$do64bit" = "yes" -a "`uname -v`" -gt "3" ; then
if test "$GCC" = "yes" ; then
AC_MSG_WARN([64bit mode not supported with GCC on $system])
else
do64bit_ok=yes
CFLAGS="$CFLAGS -q64"
LDFLAGS="$LDFLAGS -q64"
RANLIB="${RANLIB} -X64"
AR="${AR} -X64"
SHLIB_LD_FLAGS="-b64"
fi
fi
if test "`uname -m`" = "ia64" ; then
# AIX-5 uses ELF style dynamic libraries on IA-64, but not PPC
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
# AIX-5 has dl* in libc.so
DL_LIBS=""
if test "$GCC" = "yes" ; then
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
else
CC_SEARCH_FLAGS='-R${LIB_RUNTIME_DIR}'
fi
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
else
if test "$GCC" = "yes" ; then
SHLIB_LD="gcc -shared"
else
SHLIB_LD="/bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
fi
SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix ${SHLIB_LD} ${SHLIB_LD_FLAGS}"
DL_LIBS="-ldl"
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.exp'
fi
# AIX v<=4.1 has some different flags than 4.2+
if test "$system" = "AIX-4.1" -o "`uname -v`" -lt "4" ; then
LIBOBJS="$LIBOBJS tclLoadAix.o"
DL_LIBS="-lld"
fi
# On AIX <=v4 systems, libbsd.a has to be linked in to support
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 | # known GMT value. AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes, libbsd=no) if test $libbsd = yes; then MATH_LIBS="$MATH_LIBS -lbsd" AC_DEFINE(USE_DELTA_FOR_TZ) fi | | < < < < | < | > | | | | | < > > > > > > < | < > > > | > | > > > > > | | | | | | | < | | < < < < | | < < | | | | | | < | | > < | | | < > > > > > | > > > > > > | | < | > > > > > > > > > > > > < | | | < | | | | | > > > > > > > | > > > > | > | > | > > > > > > < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < > > > > > > > > < > > > | > > > > > > > > > < < | > | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | < < < | > > | | | | | < | | | < < | > < < < | > | | | > > > > > > | | | | > > > > > | > > > > > | > > > > > > > > > | | > | < | | | < | < < | | > > > > > > | 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 |
# known GMT value.
AC_CHECK_LIB(bsd, gettimeofday, libbsd=yes, libbsd=no)
if test $libbsd = yes; then
MATH_LIBS="$MATH_LIBS -lbsd"
AC_DEFINE(USE_DELTA_FOR_TZ)
fi
;;
BeOS*)
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="${CC} -nostart"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
#-----------------------------------------------------------
# Check for inet_ntoa in -lbind, for BeOS (which also needs
# -lsocket, even if the network functions are in -lnet which
# is always linked to, for compatibility.
#-----------------------------------------------------------
AC_CHECK_LIB(bind, inet_ntoa, [LIBS="$LIBS -lbind -lsocket"])
;;
BSD/OS-2.1*|BSD/OS-3*)
SHLIB_CFLAGS=""
SHLIB_LD="shlicc -r"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
BSD/OS-4.*)
SHLIB_CFLAGS="-export-dynamic -fPIC"
SHLIB_LD="cc -shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
dgux*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
HP-UX-*.11.*)
# Use updated header definitions where possible
AC_DEFINE(_XOPEN_SOURCE) # Use the XOPEN network library
AC_DEFINE(_XOPEN_SOURCE_EXTENDED) # Use the XOPEN network library
LIBS="$LIBS -lxnet" # Use the XOPEN network library
if test "`uname -m`" = "ia64" ; then
SHLIB_SUFFIX=".so"
else
SHLIB_SUFFIX=".sl"
fi
AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no)
if test "$tcl_ok" = yes; then
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
SHLIB_LD_LIBS='${LIBS}'
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="$LDFLAGS -Wl,-E"
CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
LD_LIBRARY_PATH_VAR="SHLIB_PATH"
fi
if test "$GCC" = "yes" ; then
SHLIB_LD="gcc -shared"
SHLIB_LD_LIBS='${LIBS}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
fi
# Users may want PA-RISC 1.1/2.0 portable code - needs HP cc
#CFLAGS="$CFLAGS +DAportable"
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = "yes" ; then
if test "$GCC" = "yes" ; then
hpux_arch=`${CC} -dumpmachine`
case $hpux_arch in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS='${LIBS}'
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
*)
AC_MSG_WARN([64bit mode not supported with GCC on $system])
;;
esac
else
do64bit_ok=yes
CFLAGS="$CFLAGS +DD64"
LDFLAGS="$LDFLAGS +DD64"
fi
fi
;;
HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*)
SHLIB_SUFFIX=".sl"
AC_CHECK_LIB(dld, shl_load, tcl_ok=yes, tcl_ok=no)
if test "$tcl_ok" = yes; then
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
SHLIB_LD_LIBS=""
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="$LDFLAGS -Wl,-E"
CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
LD_LIBRARY_PATH_VAR="SHLIB_PATH"
fi
;;
IRIX-4.*)
SHLIB_CFLAGS="-G 0"
SHLIB_SUFFIX=".a"
SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
SHLIB_LD_LIBS='${LIBS}'
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -Wl,-D,08000000"
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
;;
IRIX-5.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
;;
IRIX-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
if test "$GCC" = "yes" ; then
CFLAGS="$CFLAGS -mabi=n32"
LDFLAGS="$LDFLAGS -mabi=n32"
else
case $system in
IRIX-6.3)
# Use to build 6.2 compatible binaries on 6.3.
CFLAGS="$CFLAGS -n32 -D_OLD_TERMIOS"
;;
*)
CFLAGS="$CFLAGS -n32"
;;
esac
LDFLAGS="$LDFLAGS -n32"
fi
;;
IRIX64-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = "yes" ; then
if test "$GCC" = "yes" ; then
AC_MSG_WARN([64bit mode not supported by gcc])
else
do64bit_ok=yes
SHLIB_LD="ld -64 -shared -rdata_shared"
CFLAGS="$CFLAGS -64"
LDFLAGS="$LDFLAGS -64"
fi
fi
;;
Linux*)
SHLIB_CFLAGS="-fPIC"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE=-O2
# egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings
# when you inline the string and math operations. Turn this off to
# get rid of the warnings.
#CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
if test "$have_dl" = yes; then
SHLIB_LD='${CC} -shared ${CFLAGS} ${LDFLAGS}'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
else
AC_CHECK_HEADER(dld.h, [
SHLIB_LD="ld -shared"
DL_OBJS="tclLoadDld.o"
DL_LIBS="-ldld"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""])
fi
if test "`uname -m`" = "alpha" ; then
CFLAGS="$CFLAGS -mieee"
fi
if test $do64bit = yes; then
AC_CACHE_CHECK([if compiler accepts -m64 flag], tcl_cv_cc_m64, [
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -m64"
AC_TRY_LINK(,, tcl_cv_cc_m64=yes, tcl_cv_cc_m64=no)
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_m64 = yes; then
CFLAGS="$CFLAGS -m64"
do64bit_ok=yes
fi
fi
# The combo of gcc + glibc has a bug related
# to inlining of functions like strtod(). The
# -fno-builtin flag should address this problem
# but it does not work. The -fno-inline flag
# is kind of overkill but it works.
# Disable inlining only when one of the
# files in compat/*.c is being linked in.
if test x"${LIBOBJS}" != x ; then
CFLAGS="$CFLAGS -fno-inline"
fi
# XIM peeking works under XFree86.
AC_DEFINE(PEEK_XCLOSEIM)
;;
GNU*)
SHLIB_CFLAGS="-fPIC"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
if test "$have_dl" = yes; then
SHLIB_LD="${CC} -shared"
DL_OBJS=""
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
else
AC_CHECK_HEADER(dld.h, [
SHLIB_LD="ld -shared"
DL_OBJS=""
DL_LIBS="-ldld"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""])
fi
if test "`uname -m`" = "alpha" ; then
CFLAGS="$CFLAGS -mieee"
fi
;;
Lynx*)
SHLIB_CFLAGS="-fPIC"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE=-02
SHLIB_LD="${CC} -shared "
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
;;
MP-RAS-02*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
MP-RAS-*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,-Bexport"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
NetBSD-*|FreeBSD-[[1-2]].*)
# Not available on all versions: check for include file.
AC_CHECK_HEADER(dlfcn.h, [
# NetBSD/SPARC needs -fPIC, -fpic will not do.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [
AC_EGREP_CPP(yes, [
#ifdef __ELF__
yes
#endif
], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)])
if test $tcl_cv_ld_elf = yes; then
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
else
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
fi
], [
SHLIB_CFLAGS=""
SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".a"
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
])
# FreeBSD doesn't handle version numbers with dots.
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
TCL_LIB_VERSIONS_OK=nodots
;;
OpenBSD-*)
case `arch -s` in
m88k|vax)
SHLIB_CFLAGS=""
SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".a"
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS=""
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
;;
*)
# OpenBSD/SPARC[64] needs -fPIC, -fpic will not do.
case `machine` in
sparc|sparc64)
SHLIB_CFLAGS="-fPIC";;
*)
SHLIB_CFLAGS="-fpic";;
esac
SHLIB_LD="${CC} -shared ${SHLIB_CFLAGS}"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
AC_CACHE_CHECK([for ELF], tcl_cv_ld_elf, [
AC_EGREP_CPP(yes, [
#ifdef __ELF__
yes
#endif
], tcl_cv_ld_elf=yes, tcl_cv_ld_elf=no)])
if test $tcl_cv_ld_elf = yes; then
LDFLAGS=-Wl,-export-dynamic
else
LDFLAGS=""
fi
;;
esac
# OpenBSD doesn't do version numbers with dots.
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
TCL_LIB_VERSIONS_OK=nodots
;;
FreeBSD-*)
# FreeBSD 3.* and greater have ELF.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
if test "${TCL_THREADS}" = "1" ; then
# The -pthread needs to go in the CFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
fi
case $system in
FreeBSD-3.*)
# FreeBSD-3 doesn't handle version numbers with dots.
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so'
TCL_LIB_VERSIONS_OK=nodots
;;
esac
;;
Darwin-*)
CFLAGS_OPTIMIZE="-Os"
SHLIB_CFLAGS="-fno-common"
# To avoid discrepancies between what headers configure sees during
# preprocessing tests and compiling tests, move any -isysroot and
# -mmacosx-version-min flags from CFLAGS to CPPFLAGS:
CPPFLAGS="${CPPFLAGS} `echo " ${CFLAGS}" | \
awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \
if ([$]i~/^(isysroot|mmacosx-version-min)/) print "-"[$]i}'`"
CFLAGS="`echo " ${CFLAGS}" | \
awk 'BEGIN {FS=" +-";ORS=" "}; {for (i=2;i<=NF;i++) \
if (!([$]i~/^(isysroot|mmacosx-version-min)/)) print "-"[$]i}'`"
if test $do64bit = yes; then
case `arch` in
ppc)
AC_CACHE_CHECK([if compiler accepts -arch ppc64 flag],
tcl_cv_cc_arch_ppc64, [
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
AC_TRY_LINK(,, tcl_cv_cc_arch_ppc64=yes,
tcl_cv_cc_arch_ppc64=no)
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_arch_ppc64 = yes; then
CFLAGS="$CFLAGS -arch ppc64 -mpowerpc64 -mcpu=G5"
do64bit_ok=yes
fi;;
i386)
AC_CACHE_CHECK([if compiler accepts -arch x86_64 flag],
tcl_cv_cc_arch_x86_64, [
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -arch x86_64"
AC_TRY_LINK(,, tcl_cv_cc_arch_x86_64=yes,
tcl_cv_cc_arch_x86_64=no)
CFLAGS=$hold_cflags])
if test $tcl_cv_cc_arch_x86_64 = yes; then
CFLAGS="$CFLAGS -arch x86_64"
do64bit_ok=yes
fi;;
*)
AC_MSG_WARN([Don't know how enable 64-bit on architecture `arch`]);;
esac
else
# Check for combined 32-bit and 64-bit fat build
echo "$CFLAGS " | grep -E -q -- '-arch (ppc64|x86_64) ' && \
echo "$CFLAGS " | grep -E -q -- '-arch (ppc|i386) ' && \
fat_32_64=yes
fi
SHLIB_LD='${CC} -dynamiclib ${CFLAGS} ${LDFLAGS}'
AC_CACHE_CHECK([if ld accepts -single_module flag], tcl_cv_ld_single_module, [
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -dynamiclib -Wl,-single_module"
AC_TRY_LINK(, [int i;], tcl_cv_ld_single_module=yes, tcl_cv_ld_single_module=no)
LDFLAGS=$hold_ldflags])
if test $tcl_cv_ld_single_module = yes; then
SHLIB_LD="${SHLIB_LD} -Wl,-single_module"
fi
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
DL_LIBS=""
# Don't use -prebind when building for Mac OS X 10.4 or later only:
test "`echo "${MACOSX_DEPLOYMENT_TARGET}" | awk -F '10\\.' '{print int([$]2)}'`" -lt 4 -a \
"`echo "${CPPFLAGS}" | awk -F '-mmacosx-version-min=10\\.' '{print int([$]2)}'`" -lt 4 && \
LDFLAGS="$LDFLAGS -prebind"
LDFLAGS="$LDFLAGS -headerpad_max_install_names"
AC_CACHE_CHECK([if ld accepts -search_paths_first flag], tcl_cv_ld_search_paths_first, [
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
AC_TRY_LINK(, [int i;], tcl_cv_ld_search_paths_first=yes, tcl_cv_ld_search_paths_first=no)
LDFLAGS=$hold_ldflags])
if test $tcl_cv_ld_search_paths_first = yes; then
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
fi
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
PLAT_OBJS=\$\(MAC\_OSX_OBJS\)
PLAT_SRCS=\$\(MAC\_OSX_SRCS\)
AC_MSG_CHECKING([whether to use CoreFoundation])
AC_ARG_ENABLE(corefoundation, [ --enable-corefoundation use CoreFoundation API [--enable-corefoundation]],
[tcl_corefoundation=$enableval], [tcl_corefoundation=yes])
AC_MSG_RESULT([$tcl_corefoundation])
if test $tcl_corefoundation = yes; then
AC_CACHE_CHECK([for CoreFoundation.framework], tcl_cv_lib_corefoundation, [
hold_libs=$LIBS
if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do
# On Tiger there is no 64-bit CF, so remove 64-bit archs
# from CFLAGS et al. while testing for presence of CF.
# 64-bit CF is disabled in tclUnixPort.h if necessary.
eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc64 / /g" -e "s/-arch x86_64 / /g"`"'
done; fi
LIBS="$LIBS -framework CoreFoundation"
AC_TRY_LINK([#include <CoreFoundation/CoreFoundation.h>],
[CFBundleRef b = CFBundleGetMainBundle();],
tcl_cv_lib_corefoundation=yes, tcl_cv_lib_corefoundation=no)
if test "$fat_32_64" = yes; then for v in CFLAGS CPPFLAGS LDFLAGS; do
eval $v'="$hold_'$v'"'
done; fi; LIBS=$hold_libs])
if test $tcl_cv_lib_corefoundation = yes; then
LIBS="$LIBS -framework CoreFoundation"
AC_DEFINE(HAVE_COREFOUNDATION)
else
tcl_corefoundation=no
fi
if test "$fat_32_64" = yes -a $tcl_corefoundation = yes; then
AC_CACHE_CHECK([for 64-bit CoreFoundation], tcl_cv_lib_corefoundation_64, [
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval 'hold_'$v'="$'$v'";'$v'="`echo "$'$v' "|sed -e "s/-arch ppc / /g" -e "s/-arch i386 / /g"`"'
done
AC_TRY_LINK([#include <CoreFoundation/CoreFoundation.h>],
[CFBundleRef b = CFBundleGetMainBundle();],
tcl_cv_lib_corefoundation_64=yes, tcl_cv_lib_corefoundation_64=no)
for v in CFLAGS CPPFLAGS LDFLAGS; do
eval $v'="$hold_'$v'"'
done])
if test $tcl_cv_lib_corefoundation_64 = no; then
AC_DEFINE(NO_COREFOUNDATION_64)
fi
fi
fi
AC_DEFINE(MAC_OSX_TCL)
;;
NEXTSTEP-*)
SHLIB_CFLAGS=""
SHLIB_LD="cc -nostdlib -r"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadNext.o"
DL_LIBS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OS/390-*)
CFLAGS_OPTIMIZE="" # Optimizer is buggy
AC_DEFINE(_OE_SOCKETS) # needed in sys/socket.h
;;
OSF1-1.0|OSF1-1.1|OSF1-1.2)
# OSF/1 1.[012] from OSF, and derivatives, including Paragon OSF/1
SHLIB_CFLAGS=""
# Hack: make package name same as library name
SHLIB_LD='ld -R -export $@:'
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadOSF.o"
DL_LIBS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OSF1-1.*)
# OSF/1 1.3 from OSF using ELF, and derivatives, including AD2
SHLIB_CFLAGS="-fPIC"
if test "$SHARED_BUILD" = "1" ; then
SHLIB_LD="ld -shared"
else
SHLIB_LD="ld -non_shared"
fi
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OSF1-V*)
# Digital OSF/1
SHLIB_CFLAGS=""
if test "$SHARED_BUILD" = "1" ; then
SHLIB_LD='ld -shared -expect_unresolved "*"'
else
SHLIB_LD='ld -non_shared -expect_unresolved "*"'
fi
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
if test "$GCC" = "yes" ; then
CFLAGS="$CFLAGS -mieee"
else
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"
fi
# see pthread_intro(3) for pthread support on osf1, k.furukawa
if test "${TCL_THREADS}" = "1" ; then
CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
LIBS=`echo $LIBS | sed s/-lpthreads//`
if test "$GCC" = "yes" ; then
LIBS="$LIBS -lpthread -lmach -lexc"
else
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
fi
fi
;;
QNX-6*)
# QNX RTP
# This may work for all QNX, but it was only reported for v6.
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# dlopen is in -lc on QNX
DL_LIBS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
RISCos-*)
SHLIB_CFLAGS="-G 0"
SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".a"
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -Wl,-D,08000000"
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
SCO_SV-3.2*)
# Note, dlopen is available only on SCO 3.2.5 and greater. However,
# this test works, since "uname -s" was non-standard in 3.2.4 and
# below.
if test "$GCC" = "yes" ; then
SHLIB_CFLAGS="-fPIC -melf"
LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
else
SHLIB_CFLAGS="-Kpic -belf"
LDFLAGS="$LDFLAGS -belf -Wl,-Bexport"
fi
SHLIB_LD="ld -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
SINIX*5.4*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
SunOS-4*)
SHLIB_CFLAGS="-PIC"
SHLIB_LD="ld"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# SunOS can't handle version numbers with dots in them in library
# specs, like -ltcl7.5, so use -ltcl75 instead. Also, it
# requires an extra version number at the end of .so file names.
# So, the library has to have a name like libtcl75.so.1.0
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.a'
TCL_LIB_VERSIONS_OK=nodots
;;
SunOS-5.[[0-6]])
# Careful to not let 5.10+ fall into this case
# Note: If _REENTRANT isn't defined, then Solaris
# won't define thread-safe library routines.
AC_DEFINE(_REENTRANT)
AC_DEFINE(_POSIX_PTHREAD_SEMANTICS)
SHLIB_CFLAGS="-KPIC"
# Note: need the LIBS below, otherwise Tk won't find Tcl's
# symbols when dynamically loaded into tclsh.
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
if test "$GCC" = "yes" ; then
SHLIB_LD="$CC -shared"
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
else
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
CC_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
fi
;;
SunOS-5*)
# Note: If _REENTRANT isn't defined, then Solaris
# won't define thread-safe library routines.
AC_DEFINE(_REENTRANT)
AC_DEFINE(_POSIX_PTHREAD_SEMANTICS)
SHLIB_CFLAGS="-KPIC"
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = "yes" ; then
arch=`isainfo`
if test "$arch" = "sparcv9 sparc" ; then
if test "$GCC" = "yes" ; then
if test "`gcc -dumpversion | awk -F. '{print [$]1}'`" -lt "3" ; then
AC_MSG_WARN([64bit mode not supported with GCC < 3.2 on $system])
else
do64bit_ok=yes
CFLAGS="$CFLAGS -m64 -mcpu=v9"
LDFLAGS="$LDFLAGS -m64 -mcpu=v9"
SHLIB_CFLAGS="-fPIC"
fi
else
do64bit_ok=yes
if test "$do64bitVIS" = "yes" ; then
CFLAGS="$CFLAGS -xarch=v9a"
LDFLAGS="$LDFLAGS -xarch=v9a"
else
CFLAGS="$CFLAGS -xarch=v9"
LDFLAGS="$LDFLAGS -xarch=v9"
fi
# Solaris 64 uses this as well
#LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH_64"
fi
elif test "$arch" = "amd64 i386" ; then
if test "$GCC" = "yes" ; then
AC_MSG_WARN([64bit mode not supported with GCC on $system])
else
do64bit_ok=yes
CFLAGS="$CFLAGS -xarch=amd64"
LDFLAGS="$LDFLAGS -xarch=amd64"
fi
else
AC_MSG_WARN([64bit mode not supported for $arch])
fi
fi
# Note: need the LIBS below, otherwise Tk won't find Tcl's
# symbols when dynamically loaded into tclsh.
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
if test "$GCC" = "yes" ; then
SHLIB_LD="$CC -shared"
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
if test "$do64bit_ok" = "yes" ; then
# We need to specify -static-libgcc or we need to
# add the path to the sparv9 libgcc.
SHLIB_LD="$SHLIB_LD -m64 -mcpu=v9 -static-libgcc"
# for finding sparcv9 libgcc, get the regular libgcc
# path, remove so name and append 'sparcv9'
#v9gcclibdir="`gcc -print-file-name=libgcc_s.so` | ..."
#CC_SEARCH_FLAGS="${CC_SEARCH_FLAGS},-R,$v9gcclibdir"
fi
else
SHLIB_LD="/usr/ccs/bin/ld -G -z text"
CC_SEARCH_FLAGS='-Wl,-R,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-R ${LIB_RUNTIME_DIR}'
fi
;;
ULTRIX-4.*)
SHLIB_CFLAGS="-G 0"
SHLIB_SUFFIX=".a"
SHLIB_LD="echo tclLdAout $CC \{$SHLIB_CFLAGS\} | `pwd`/tclsh -r -G 0"
SHLIB_LD_LIBS='${LIBS}'
DL_OBJS="tclLoadAout.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -Wl,-D,08000000"
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
if test "$GCC" != "yes" ; then
CFLAGS="$CFLAGS -DHAVE_TZSET -std1"
fi
;;
UNIX_SV* | UnixWare-5*)
SHLIB_CFLAGS="-KPIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
# Some UNIX_SV* systems (unixware 1.1.2 for example) have linkers
# that don't grok the -Bexport option. Test that it does.
AC_CACHE_CHECK([for ld accepts -Bexport flag], tcl_cv_ld_Bexport, [
hold_ldflags=$LDFLAGS
LDFLAGS="$LDFLAGS -Wl,-Bexport"
AC_TRY_LINK(, [int i;], tcl_cv_ld_Bexport=yes, tcl_cv_ld_Bexport=no)
LDFLAGS=$hold_ldflags])
if test $tcl_cv_ld_Bexport = yes; then
LDFLAGS="$LDFLAGS -Wl,-Bexport"
fi
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
esac
if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
AC_MSG_WARN([64bit support being disabled -- don't know magic for this platform])
fi
dnl # Add any CPPFLAGS set in the environment to our CFLAGS, but delay doing so
dnl # until the end of configure, as configure's compile and link tests use
dnl # both CPPFLAGS and CFLAGS (unlike our compile and link) but configure's
dnl # preprocessing tests use only CPPFLAGS.
SC_CONFIG_COMMANDS_PRE([CFLAGS="${CFLAGS} ${CPPFLAGS}"; CPPFLAGS=""])
# Step 4: If pseudo-static linking is in use (see K. B. Kenny, "Dynamic
# Loading for Tcl -- What Became of It?". Proc. 2nd Tcl/Tk Workshop,
# New Orleans, LA, Computerized Processes Unlimited, 1994), then we need
# to determine which of several header files defines the a.out file
# format (a.out.h, sys/exec.h, or sys/exec_aout.h). At present, we
# support only a file format that is more or less version-7-compatible.
|
| ︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 |
# or a.out.h is usable for the purpose.
#
# Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the
# `struct exec' includes a second header that contains information that
# duplicates the v7 fields that are needed.
if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
| | | < | | | < | | | < | | 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 |
# or a.out.h is usable for the purpose.
#
# Note that the modified COFF format used on MIPS Ultrix 4.x is usable; the
# `struct exec' includes a second header that contains information that
# duplicates the v7 fields that are needed.
if test "x$DL_OBJS" = "xtclLoadAout.o" ; then
AC_CACHE_CHECK([sys/exec.h], tcl_cv_sysexec_h, [
AC_TRY_COMPILE([#include <sys/exec.h>],[
struct exec foo;
unsigned long seek;
int flag;
#if defined(__mips) || defined(mips)
seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
seek = N_TXTOFF (foo);
#endif
flag = (foo.a_magic == OMAGIC);
return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
], tcl_cv_sysexec_h=usable, tcl_cv_sysexec_h=unusable)])
if test $tcl_cv_sysexec_h = usable; then
AC_DEFINE(USE_SYS_EXEC_H)
else
AC_CACHE_CHECK([a.out.h], tcl_cv_aout_h, [
AC_TRY_COMPILE([#include <a.out.h>],[
struct exec foo;
unsigned long seek;
int flag;
#if defined(__mips) || defined(mips)
seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
seek = N_TXTOFF (foo);
#endif
flag = (foo.a_magic == OMAGIC);
return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
], tcl_cv_aout_h=usable, tcl_cv_aout_h=unusable)])
if test $tcl_cv_aout_h = usable; then
AC_DEFINE(USE_A_OUT_H)
else
AC_CACHE_CHECK([sys/exec_aout.h], tcl_cv_sysexecaout_h, [
AC_TRY_COMPILE([#include <sys/exec_aout.h>],[
struct exec foo;
unsigned long seek;
int flag;
#if defined(__mips) || defined(mips)
seek = N_TXTOFF (foo.ex_f, foo.ex_o);
#else
seek = N_TXTOFF (foo);
#endif
flag = (foo.a_midmag == OMAGIC);
return foo.a_text + foo.a_data + foo.a_bss + foo.a_entry;
], tcl_cv_sysexecaout_h=usable, tcl_cv_sysexecaout_h=unusable)])
if test $tcl_cv_sysexecaout_h = usable; then
AC_DEFINE(USE_SYS_EXEC_AOUT_H)
else
DL_OBJS=""
fi
fi
fi
fi
|
| ︙ | ︙ | |||
1636 1637 1638 1639 1640 1641 1642 | echo "Can't figure out how to do dynamic loading or shared libraries" echo "on this system." SHLIB_CFLAGS="" SHLIB_LD="" SHLIB_SUFFIX="" DL_OBJS="tclLoadNone.o" DL_LIBS="" | | | | 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 |
echo "Can't figure out how to do dynamic loading or shared libraries"
echo "on this system."
SHLIB_CFLAGS=""
SHLIB_LD=""
SHLIB_SUFFIX=""
DL_OBJS="tclLoadNone.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS_ORIG"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
BUILD_DLTEST=""
fi
# If we're running gcc, then change the C flags for compiling shared
# libraries to the right flags for gcc, instead of those for the
# standard manufacturer compiler.
if test "$DL_OBJS" != "tclLoadNone.o" ; then
if test "$GCC" = "yes" ; then
case $system in
AIX-*)
;;
BSD/OS*)
;;
IRIX*)
;;
NetBSD-*|FreeBSD-*|OpenBSD-*)
;;
Darwin-*)
;;
RISCos-*)
;;
SCO_SV-3.2*)
;;
ULTRIX-4.*)
;;
|
| ︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 |
fi
if test "$UNSHARED_LIB_SUFFIX" = "" ; then
UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
fi
if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
| | | 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 |
fi
if test "$UNSHARED_LIB_SUFFIX" = "" ; then
UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
fi
if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
else
LIB_SUFFIX=${UNSHARED_LIB_SUFFIX}
if test "$RANLIB" = "" ; then
MAKE_LIB='$(STLIB_LD) [$]@ ${OBJS}'
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE)'
|
| ︙ | ︙ | |||
1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 |
fi
AC_SUBST(DL_LIBS)
AC_SUBST(DL_OBJS)
AC_SUBST(PLAT_OBJS)
AC_SUBST(CFLAGS)
AC_SUBST(CFLAGS_DEBUG)
AC_SUBST(CFLAGS_OPTIMIZE)
AC_SUBST(CFLAGS_WARNING)
| > < < | 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 |
fi
AC_SUBST(DL_LIBS)
AC_SUBST(DL_OBJS)
AC_SUBST(PLAT_OBJS)
AC_SUBST(PLAT_SRCS)
AC_SUBST(CFLAGS)
AC_SUBST(CFLAGS_DEBUG)
AC_SUBST(CFLAGS_OPTIMIZE)
AC_SUBST(CFLAGS_WARNING)
AC_SUBST(LDFLAGS)
AC_SUBST(LDFLAGS_DEBUG)
AC_SUBST(LDFLAGS_OPTIMIZE)
AC_SUBST(CC_SEARCH_FLAGS)
AC_SUBST(LD_SEARCH_FLAGS)
AC_SUBST(STLIB_LD)
AC_SUBST(SHLIB_LD)
AC_SUBST(TCL_SHLIB_LD_EXTRAS)
AC_SUBST(TK_SHLIB_LD_EXTRAS)
AC_SUBST(SHLIB_LD_LIBS)
AC_SUBST(SHLIB_CFLAGS)
AC_SUBST(SHLIB_SUFFIX)
AC_SUBST(MAKE_LIB)
AC_SUBST(MAKE_STUB_LIB)
AC_SUBST(INSTALL_LIB)
|
| ︙ | ︙ | |||
1774 1775 1776 1777 1778 1779 1780 | # HAVE_SYS_MODEM_H # USE_TERMIOS # USE_TERMIO # USE_SGTTY # #-------------------------------------------------------------------- | | | < | 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 |
# HAVE_SYS_MODEM_H
# USE_TERMIOS
# USE_TERMIO
# USE_SGTTY
#
#--------------------------------------------------------------------
AC_DEFUN([SC_SERIAL_PORT], [
AC_CHECK_HEADERS(sys/modem.h)
AC_CACHE_CHECK([termios vs. termio vs. sgtty], tcl_cv_api_serial, [
AC_TRY_RUN([
#include <termios.h>
int main() {
struct termios t;
if (tcgetattr(0, &t) == 0) {
cfsetospeed(&t, 0);
|
| ︙ | ︙ | |||
1869 1870 1871 1872 1873 1874 1875 |
}], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=none, tcl_cv_api_serial=none)
fi])
case $tcl_cv_api_serial in
termios) AC_DEFINE(USE_TERMIOS);;
termio) AC_DEFINE(USE_TERMIO);;
sgtty) AC_DEFINE(USE_SGTTY);;
esac
| < | 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 |
}], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=none, tcl_cv_api_serial=none)
fi])
case $tcl_cv_api_serial in
termios) AC_DEFINE(USE_TERMIOS);;
termio) AC_DEFINE(USE_TERMIO);;
sgtty) AC_DEFINE(USE_SGTTY);;
esac
])
#--------------------------------------------------------------------
# SC_MISSING_POSIX_HEADERS
#
# Supply substitutes for missing POSIX header files. Special
# notes:
|
| ︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 | # # Results: # # Defines some of the following vars: # NO_DIRENT_H # NO_ERRNO_H # NO_VALUES_H | | | | | | < | > | 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 |
#
# Results:
#
# Defines some of the following vars:
# NO_DIRENT_H
# NO_ERRNO_H
# NO_VALUES_H
# HAVE_LIMITS_H or NO_LIMITS_H
# NO_STDLIB_H
# NO_STRING_H
# NO_SYS_WAIT_H
# NO_DLFCN_H
# HAVE_UNISTD_H
# HAVE_SYS_PARAM_H
#
# HAVE_STRING_H ?
#
#--------------------------------------------------------------------
AC_DEFUN([SC_MISSING_POSIX_HEADERS], [
AC_CACHE_CHECK([dirent.h], tcl_cv_dirent_h, [
AC_TRY_LINK([#include <sys/types.h>
#include <dirent.h>], [
#ifndef _POSIX_SOURCE
# ifdef __Lynx__
/*
* Generate compilation error to make the test fail: Lynx headers
* are only valid if really in the POSIX environment.
*/
missing_procedure();
# endif
#endif
DIR *d;
struct dirent *entryPtr;
char *p;
d = opendir("foobar");
entryPtr = readdir(d);
p = entryPtr->d_name;
closedir(d);
], tcl_cv_dirent_h=yes, tcl_cv_dirent_h=no)])
if test $tcl_cv_dirent_h = no; then
AC_DEFINE(NO_DIRENT_H)
fi
AC_CHECK_HEADER(errno.h, , [AC_DEFINE(NO_ERRNO_H)])
AC_CHECK_HEADER(float.h, , [AC_DEFINE(NO_FLOAT_H)])
AC_CHECK_HEADER(values.h, , [AC_DEFINE(NO_VALUES_H)])
AC_CHECK_HEADER(limits.h,
[AC_DEFINE(HAVE_LIMITS_H)], [AC_DEFINE(NO_LIMITS_H)])
AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0)
AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0)
AC_EGREP_HEADER(strtod, stdlib.h, , tcl_ok=0)
if test $tcl_ok = 0; then
AC_DEFINE(NO_STDLIB_H)
fi
|
| ︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 |
AC_DEFINE(NO_STRING_H)
fi
AC_CHECK_HEADER(sys/wait.h, , [AC_DEFINE(NO_SYS_WAIT_H)])
AC_CHECK_HEADER(dlfcn.h, , [AC_DEFINE(NO_DLFCN_H)])
# OS/390 lacks sys/param.h (and doesn't need it, by chance).
| < < | 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 |
AC_DEFINE(NO_STRING_H)
fi
AC_CHECK_HEADER(sys/wait.h, , [AC_DEFINE(NO_SYS_WAIT_H)])
AC_CHECK_HEADER(dlfcn.h, , [AC_DEFINE(NO_DLFCN_H)])
# OS/390 lacks sys/param.h (and doesn't need it, by chance).
AC_HAVE_HEADERS(unistd.h sys/param.h)
])
#--------------------------------------------------------------------
# SC_PATH_X
#
# Locate the X11 header files and the X11 library archive. Try
# the ac_path_x macro first, but if it doesn't find the X stuff
|
| ︙ | ︙ | |||
1983 1984 1985 1986 1987 1988 1989 | # # Sets the the following vars: # XINCLUDES # XLIBSW # #-------------------------------------------------------------------- | | | | | | | | > | 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 |
#
# Sets the the following vars:
# XINCLUDES
# XLIBSW
#
#--------------------------------------------------------------------
AC_DEFUN([SC_PATH_X], [
AC_PATH_X
not_really_there=""
if test "$no_x" = ""; then
if test "$x_includes" = ""; then
AC_TRY_CPP([#include <X11/XIntrinsic.h>], , not_really_there="yes")
else
if test ! -r $x_includes/X11/Intrinsic.h; then
not_really_there="yes"
fi
fi
fi
if test "$no_x" = "yes" -o "$not_really_there" = "yes"; then
AC_MSG_CHECKING([for X11 header files])
found_xincludes="no"
AC_TRY_CPP([#include <X11/Intrinsic.h>], found_xincludes="yes", found_xincludes="no")
if test "$found_xincludes" = "no"; then
dirs="/usr/unsupported/include /usr/local/include /usr/X386/include /usr/X11R6/include /usr/X11R5/include /usr/include/X11R5 /usr/include/X11R4 /usr/openwin/include /usr/X11/include /usr/sww/include"
for i in $dirs ; do
if test -r $i/X11/Intrinsic.h; then
AC_MSG_RESULT([$i])
XINCLUDES=" -I$i"
found_xincludes="yes"
break
fi
done
fi
else
if test "$x_includes" != ""; then
XINCLUDES="-I$x_includes"
found_xincludes="yes"
fi
fi
if test found_xincludes = "no"; then
AC_MSG_RESULT([couldn't find any!])
fi
if test "$no_x" = yes; then
AC_MSG_CHECKING([for X11 libraries])
XLIBSW=nope
dirs="/usr/unsupported/lib /usr/local/lib /usr/X386/lib /usr/X11R6/lib /usr/X11R5/lib /usr/lib/X11R5 /usr/lib/X11R4 /usr/openwin/lib /usr/X11/lib /usr/sww/X11/lib"
for i in $dirs ; do
if test -r $i/libX11.a -o -r $i/libX11.so -o -r $i/libX11.sl; then
AC_MSG_RESULT([$i])
XLIBSW="-L$i -lX11"
x_libraries="$i"
break
fi
done
else
if test "$x_libraries" = ""; then
XLIBSW=-lX11
else
XLIBSW="-L$x_libraries -lX11"
fi
fi
if test "$XLIBSW" = nope ; then
AC_CHECK_LIB(Xwindow, XCreateWindow, XLIBSW=-lXwindow)
fi
if test "$XLIBSW" = nope ; then
AC_MSG_RESULT([could not find any! Using -lX11.])
XLIBSW=-lX11
fi
])
#--------------------------------------------------------------------
# SC_BLOCKING_STYLE
#
# The statements below check for systems where POSIX-style
# non-blocking I/O (O_NONBLOCK) doesn't work or is unimplemented.
# On these systems (mostly older ones), use the old BSD-style
# FIONBIO approach instead.
|
| ︙ | ︙ | |||
2068 2069 2070 2071 2072 2073 2074 | # HAVE_SYS_IOCTL_H # HAVE_SYS_FILIO_H # USE_FIONBIO # O_NONBLOCK # #-------------------------------------------------------------------- | | > < < < < < < < < < < < < < < < < < < | | | | | 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 |
# HAVE_SYS_IOCTL_H
# HAVE_SYS_FILIO_H
# USE_FIONBIO
# O_NONBLOCK
#
#--------------------------------------------------------------------
AC_DEFUN([SC_BLOCKING_STYLE], [
AC_CHECK_HEADERS(sys/ioctl.h)
AC_CHECK_HEADERS(sys/filio.h)
SC_CONFIG_SYSTEM
AC_MSG_CHECKING([FIONBIO vs. O_NONBLOCK for nonblocking I/O])
case $system in
# There used to be code here to use FIONBIO under AIX. However, it
# was reported that FIONBIO doesn't work under AIX 3.2.5. Since
# using O_NONBLOCK seems fine under AIX 4.*, I removed the FIONBIO
# code (JO, 5/31/97).
OSF*)
AC_DEFINE(USE_FIONBIO)
AC_MSG_RESULT([FIONBIO])
;;
SunOS-4*)
AC_DEFINE(USE_FIONBIO)
AC_MSG_RESULT([FIONBIO])
;;
ULTRIX-4.*)
AC_DEFINE(USE_FIONBIO)
AC_MSG_RESULT([FIONBIO])
;;
*)
AC_MSG_RESULT([O_NONBLOCK])
;;
esac
])
#--------------------------------------------------------------------
# SC_TIME_HANLDER
#
|
| ︙ | ︙ | |||
2133 2134 2135 2136 2137 2138 2139 | # USE_DELTA_FOR_TZ # HAVE_TM_GMTOFF # HAVE_TM_TZADJ # HAVE_TIMEZONE_VAR # #-------------------------------------------------------------------- | | | < | < | < | < | < | < | < | < | 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 |
# USE_DELTA_FOR_TZ
# HAVE_TM_GMTOFF
# HAVE_TM_TZADJ
# HAVE_TIMEZONE_VAR
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TIME_HANDLER], [
AC_CHECK_HEADERS(sys/time.h)
AC_HEADER_TIME
AC_STRUCT_TIMEZONE
AC_CHECK_FUNCS(gmtime_r localtime_r)
AC_CACHE_CHECK([tm_tzadj in struct tm], tcl_cv_member_tm_tzadj, [
AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_tzadj;],
tcl_cv_member_tm_tzadj=yes, tcl_cv_member_tm_tzadj=no)])
if test $tcl_cv_member_tm_tzadj = yes ; then
AC_DEFINE(HAVE_TM_TZADJ)
fi
AC_CACHE_CHECK([tm_gmtoff in struct tm], tcl_cv_member_tm_gmtoff, [
AC_TRY_COMPILE([#include <time.h>], [struct tm tm; tm.tm_gmtoff;],
tcl_cv_member_tm_gmtoff=yes, tcl_cv_member_tm_gmtoff=no)])
if test $tcl_cv_member_tm_gmtoff = yes ; then
AC_DEFINE(HAVE_TM_GMTOFF)
fi
#
# Its important to include time.h in this check, as some systems
# (like convex) have timezone functions, etc.
#
AC_CACHE_CHECK([long timezone variable], tcl_cv_timezone_long, [
AC_TRY_COMPILE([#include <time.h>],
[extern long timezone;
timezone += 1;
exit (0);],
tcl_cv_timezone_long=yes, tcl_cv_timezone_long=no)])
if test $tcl_cv_timezone_long = yes ; then
AC_DEFINE(HAVE_TIMEZONE_VAR)
else
#
# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
#
AC_CACHE_CHECK([time_t timezone variable], tcl_cv_timezone_time, [
AC_TRY_COMPILE([#include <time.h>],
[extern time_t timezone;
timezone += 1;
exit (0);],
tcl_cv_timezone_time=yes, tcl_cv_timezone_time=no)])
if test $tcl_cv_timezone_time = yes ; then
AC_DEFINE(HAVE_TIMEZONE_VAR)
fi
fi
])
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
2210 2211 2212 2213 2214 2215 2216 | # Results: # # Might defines some of the following vars: # strtod (=fixstrtod) # #-------------------------------------------------------------------- | | | < > | | < < < | 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 |
# Results:
#
# Might defines some of the following vars:
# strtod (=fixstrtod)
#
#--------------------------------------------------------------------
AC_DEFUN([SC_BUGGY_STRTOD], [
AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0)
if test "$tcl_strtod" = 1; then
AC_CACHE_CHECK([for Solaris2.4/Tru64 strtod bugs], tcl_cv_strtod_buggy,[
AC_TRY_RUN([
extern double strtod();
int main() {
char *infString="Inf", *nanString="NaN", *spaceString=" ";
char *term;
double value;
value = strtod(infString, &term);
if ((term != infString) && (term[-1] == 0)) {
exit(1);
}
value = strtod(nanString, &term);
if ((term != nanString) && (term[-1] == 0)) {
exit(1);
}
value = strtod(spaceString, &term);
if (term == (spaceString+1)) {
exit(1);
}
exit(0);
}], tcl_cv_strtod_buggy=ok, tcl_cv_strtod_buggy=buggy,
tcl_cv_strtod_buggy=buggy)])
if test "$tcl_cv_strtod_buggy" = buggy; then
LIBOBJS="$LIBOBJS fixstrtod.o"
AC_DEFINE(strtod, fixstrtod)
fi
fi
])
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
2272 2273 2274 2275 2276 2277 2278 | # LIBS # # Might define the following vars: # HAVE_NET_ERRNO_H # #-------------------------------------------------------------------- | | | 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 |
# LIBS
#
# Might define the following vars:
# HAVE_NET_ERRNO_H
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_LINK_LIBS], [
#--------------------------------------------------------------------
# On a few very rare systems, all of the libm.a stuff is
# already in libc.a. Set compiler flags accordingly.
# Also, Linux requires the "ieee" library for math to work
# right (and it must appear before "-lm").
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 | # None # # Results: # # Might define the following vars: # _ISOC99_SOURCE # _LARGEFILE64_SOURCE # #-------------------------------------------------------------------- | > | | > | > > | | | > | | | | | | < | < < | < > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > | > > | 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 |
# None
#
# Results:
#
# Might define the following vars:
# _ISOC99_SOURCE
# _LARGEFILE64_SOURCE
# _LARGEFILE_SOURCE64
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_EARLY_FLAG],[
AC_CACHE_VAL([tcl_cv_flag_]translit($1,[A-Z],[a-z]),
AC_TRY_COMPILE([$2], $3, [tcl_cv_flag_]translit($1,[A-Z],[a-z])=no,
AC_TRY_COMPILE([[#define ]$1[ 1
]$2], $3,
[tcl_cv_flag_]translit($1,[A-Z],[a-z])=yes,
[tcl_cv_flag_]translit($1,[A-Z],[a-z])=no)))
if test ["x${tcl_cv_flag_]translit($1,[A-Z],[a-z])[}" = "xyes"] ; then
AC_DEFINE($1)
tcl_flags="$tcl_flags $1"
fi
])
AC_DEFUN([SC_TCL_EARLY_FLAGS],[
AC_MSG_CHECKING([for required early compiler flags])
tcl_flags=""
SC_TCL_EARLY_FLAG(_ISOC99_SOURCE,[#include <stdlib.h>],
[char *p = (char *)strtoll; char *q = (char *)strtoull;])
SC_TCL_EARLY_FLAG(_LARGEFILE64_SOURCE,[#include <sys/stat.h>],
[struct stat64 buf; int i = stat64("/", &buf);])
SC_TCL_EARLY_FLAG(_LARGEFILE_SOURCE64,[#include <sys/stat.h>],
[char *p = (char *)open64;])
if test "x${tcl_flags}" = "x" ; then
AC_MSG_RESULT([none])
else
AC_MSG_RESULT([${tcl_flags}])
fi
])
#--------------------------------------------------------------------
# SC_TCL_64BIT_FLAGS
#
# Check for what is defined in the way of 64-bit features.
#
# Arguments:
# None
#
# Results:
#
# Might define the following vars:
# TCL_WIDE_INT_IS_LONG
# TCL_WIDE_INT_TYPE
# HAVE_STRUCT_DIRENT64
# HAVE_STRUCT_STAT64
# HAVE_TYPE_OFF64_T
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_64BIT_FLAGS], [
AC_MSG_CHECKING([for 64-bit integer type])
AC_CACHE_VAL(tcl_cv_type_64bit,[
tcl_cv_type_64bit=none
# See if the compiler knows natively about __int64
AC_TRY_COMPILE(,[__int64 value = (__int64) 0;],
tcl_type_64bit=__int64, tcl_type_64bit="long long")
# See if we should use long anyway Note that we substitute in the
# type that is our current guess for a 64-bit type inside this check
# program, so it should be modified only carefully...
AC_TRY_COMPILE(,[switch (0) {
case 1: case (sizeof(]${tcl_type_64bit}[)==sizeof(long)): ;
}],tcl_cv_type_64bit=${tcl_type_64bit})])
if test "${tcl_cv_type_64bit}" = none ; then
AC_DEFINE(TCL_WIDE_INT_IS_LONG)
AC_MSG_RESULT([using long])
else
AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit})
AC_MSG_RESULT([${tcl_cv_type_64bit}])
# Now check for auxiliary declarations
AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[
AC_TRY_COMPILE([#include <sys/types.h>
#include <sys/dirent.h>],[struct dirent64 p;],
tcl_cv_struct_dirent64=yes,tcl_cv_struct_dirent64=no)])
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
AC_DEFINE(HAVE_STRUCT_DIRENT64)
fi
AC_CACHE_CHECK([for struct stat64], tcl_cv_struct_stat64,[
AC_TRY_COMPILE([#include <sys/stat.h>],[struct stat64 p;
],
tcl_cv_struct_stat64=yes,tcl_cv_struct_stat64=no)])
if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
AC_DEFINE(HAVE_STRUCT_STAT64)
fi
AC_CHECK_FUNCS(open64 lseek64)
AC_MSG_CHECKING([for off64_t])
AC_CACHE_VAL(tcl_cv_type_off64_t,[
AC_TRY_COMPILE([#include <sys/types.h>],[off64_t offset;
],
tcl_cv_type_off64_t=yes,tcl_cv_type_off64_t=no)])
dnl Define HAVE_TYPE_OFF64_T only when the off64_t type and the
dnl functions lseek64 and open64 are defined.
if test "x${tcl_cv_type_off64_t}" = "xyes" && \
test "x${ac_cv_func_lseek64}" = "xyes" && \
test "x${ac_cv_func_open64}" = "xyes" ; then
AC_DEFINE(HAVE_TYPE_OFF64_T)
AC_MSG_RESULT([yes])
else
AC_MSG_RESULT([no])
fi
fi
])
#--------------------------------------------------------------------
# SC_TCL_GETHOSTBYADDR_R
#
# Check if we have MT-safe variant of gethostbyaddr().
#
# Arguments:
# None
#
# Results:
#
# Might define the following vars:
# HAVE_GETHOSTBYADDR_R
# HAVE_GETHOSTBYADDR_R_7
# HAVE_GETHOSTBYADDR_R_8
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETHOSTBYADDR_R], [AC_CHECK_FUNC(gethostbyaddr_r, [
AC_CACHE_CHECK([for gethostbyaddr_r with 7 args], tcl_cv_api_gethostbyaddr_r_7, [
AC_TRY_COMPILE([
#include <netdb.h>
], [
char *addr;
int length;
int type;
struct hostent *result;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyaddr_r(addr, length, type, result, buffer, buflen,
&h_errnop);
], tcl_cv_api_gethostbyaddr_r_7=yes, tcl_cv_api_gethostbyaddr_r_7=no)])
tcl_ok=$tcl_cv_api_gethostbyaddr_r_7
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYADDR_R_7)
else
AC_CACHE_CHECK([for gethostbyaddr_r with 8 args], tcl_cv_api_gethostbyaddr_r_8, [
AC_TRY_COMPILE([
#include <netdb.h>
], [
char *addr;
int length;
int type;
struct hostent *result, *resultp;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyaddr_r(addr, length, type, result, buffer, buflen,
&resultp, &h_errnop);
], tcl_cv_api_gethostbyaddr_r_8=yes, tcl_cv_api_gethostbyaddr_r_8=no)])
tcl_ok=$tcl_cv_api_gethostbyaddr_r_8
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYADDR_R_8)
fi
fi
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYADDR_R)
fi
])])
#--------------------------------------------------------------------
# SC_TCL_GETHOSTBYNAME_R
#
# Check to see what variant of gethostbyname_r() we have.
# Based on David Arnold's example from the comp.programming.threads
# FAQ Q213
#
# Arguments:
# None
#
# Results:
#
# Might define the following vars:
# HAVE_GETHOSTBYADDR_R
# HAVE_GETHOSTBYADDR_R_3
# HAVE_GETHOSTBYADDR_R_5
# HAVE_GETHOSTBYADDR_R_6
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETHOSTBYNAME_R], [AC_CHECK_FUNC(gethostbyname_r, [
AC_CACHE_CHECK([for gethostbyname_r with 6 args], tcl_cv_api_gethostbyname_r_6, [
AC_TRY_COMPILE([
#include <netdb.h>
], [
char *name;
struct hostent *he, *res;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyname_r(name, he, buffer, buflen, &res, &h_errnop);
], tcl_cv_api_gethostbyname_r_6=yes, tcl_cv_api_gethostbyname_r_6=no)])
tcl_ok=$tcl_cv_api_gethostbyname_r_6
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYNAME_R_6)
else
AC_CACHE_CHECK([for gethostbyname_r with 5 args], tcl_cv_api_gethostbyname_r_5, [
AC_TRY_COMPILE([
#include <netdb.h>
], [
char *name;
struct hostent *he;
char buffer[2048];
int buflen = 2048;
int h_errnop;
(void) gethostbyname_r(name, he, buffer, buflen, &h_errnop);
], tcl_cv_api_gethostbyname_r_5=yes, tcl_cv_api_gethostbyname_r_5=no)])
tcl_ok=$tcl_cv_api_gethostbyname_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYNAME_R_5)
else
AC_CACHE_CHECK([for gethostbyname_r with 3 args], tcl_cv_api_gethostbyname_r_3, [
AC_TRY_COMPILE([
#include <netdb.h>
], [
char *name;
struct hostent *he;
struct hostent_data data;
(void) gethostbyname_r(name, he, &data);
], tcl_cv_api_gethostbyname_r_3=yes, tcl_cv_api_gethostbyname_r_3=no)])
tcl_ok=$tcl_cv_api_gethostbyname_r_3
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYNAME_R_3)
fi
fi
fi
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETHOSTBYNAME_R)
fi
])])
#--------------------------------------------------------------------
# SC_TCL_GETPWUID_R
#
# Check if we have MT-safe variant of getpwuid() and if yes,
# which one exactly.
#
# Arguments:
# None
#
# Results:
#
# Might define the following vars:
# HAVE_GETPWUID_R
# HAVE_GETPWUID_R_4
# HAVE_GETPWUID_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETPWUID_R], [AC_CHECK_FUNC(getpwuid_r, [
AC_CACHE_CHECK([for getpwuid_r with 5 args], tcl_cv_api_getpwuid_r_5, [
AC_TRY_COMPILE([
#include <sys/types.h>
#include <pwd.h>
], [
uid_t uid;
struct passwd pw, *pwp;
char buf[512];
int buflen = 512;
(void) getpwuid_r(uid, &pw, buf, buflen, &pwp);
], tcl_cv_api_getpwuid_r_5=yes, tcl_cv_api_getpwuid_r_5=no)])
tcl_ok=$tcl_cv_api_getpwuid_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWUID_R_5)
else
AC_CACHE_CHECK([for getpwuid_r with 4 args], tcl_cv_api_getpwuid_r_4, [
AC_TRY_COMPILE([
#include <sys/types.h>
#include <pwd.h>
], [
uid_t uid;
struct passwd pw;
char buf[512];
int buflen = 512;
(void)getpwnam_r(uid, &pw, buf, buflen);
], tcl_cv_api_getpwuid_r_4=yes, tcl_cv_api_getpwuid_r_4=no)])
tcl_ok=$tcl_cv_api_getpwuid_r_4
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWUID_R_4)
fi
fi
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWUID_R)
fi
])])
#--------------------------------------------------------------------
# SC_TCL_GETPWNAM_R
#
# Check if we have MT-safe variant of getpwnam() and if yes,
# which one exactly.
#
# Arguments:
# None
#
# Results:
#
# Might define the following vars:
# HAVE_GETPWNAM_R
# HAVE_GETPWNAM_R_4
# HAVE_GETPWNAM_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETPWNAM_R], [AC_CHECK_FUNC(getpwnam_r, [
AC_CACHE_CHECK([for getpwnam_r with 5 args], tcl_cv_api_getpwnam_r_5, [
AC_TRY_COMPILE([
#include <sys/types.h>
#include <pwd.h>
], [
char *name;
struct passwd pw, *pwp;
char buf[512];
int buflen = 512;
(void) getpwnam_r(name, &pw, buf, buflen, &pwp);
], tcl_cv_api_getpwnam_r_5=yes, tcl_cv_api_getpwnam_r_5=no)])
tcl_ok=$tcl_cv_api_getpwnam_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWNAM_R_5)
else
AC_CACHE_CHECK([for getpwnam_r with 4 args], tcl_cv_api_getpwnam_r_4, [
AC_TRY_COMPILE([
#include <sys/types.h>
#include <pwd.h>
], [
char *name;
struct passwd pw;
char buf[512];
int buflen = 512;
(void)getpwnam_r(name, &pw, buf, buflen);
], tcl_cv_api_getpwnam_r_4=yes, tcl_cv_api_getpwnam_r_4=no)])
tcl_ok=$tcl_cv_api_getpwnam_r_4
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWNAM_R_4)
fi
fi
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETPWNAM_R)
fi
])])
#--------------------------------------------------------------------
# SC_TCL_GETGRGID_R
#
# Check if we have MT-safe variant of getgrgid() and if yes,
# which one exactly.
#
# Arguments:
# None
#
# Results:
#
# Might define the following vars:
# HAVE_GETGRGID_R
# HAVE_GETGRGID_R_4
# HAVE_GETGRGID_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETGRGID_R], [AC_CHECK_FUNC(getgrgid_r, [
AC_CACHE_CHECK([for getgrgid_r with 5 args], tcl_cv_api_getgrgid_r_5, [
AC_TRY_COMPILE([
#include <sys/types.h>
#include <grp.h>
], [
gid_t gid;
struct group gr, *grp;
char buf[512];
int buflen = 512;
(void) getgrgid_r(gid, &gr, buf, buflen, &grp);
], tcl_cv_api_getgrgid_r_5=yes, tcl_cv_api_getgrgid_r_5=no)])
tcl_ok=$tcl_cv_api_getgrgid_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRGID_R_5)
else
AC_CACHE_CHECK([for getgrgid_r with 4 args], tcl_cv_api_getgrgid_r_4, [
AC_TRY_COMPILE([
#include <sys/types.h>
#include <grp.h>
], [
gid_t gid;
struct group gr;
char buf[512];
int buflen = 512;
(void)getgrgid_r(gid, &gr, buf, buflen);
], tcl_cv_api_getgrgid_r_4=yes, tcl_cv_api_getgrgid_r_4=no)])
tcl_ok=$tcl_cv_api_getgrgid_r_4
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRGID_R_4)
fi
fi
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRGID_R)
fi
])])
#--------------------------------------------------------------------
# SC_TCL_GETGRNAM_R
#
# Check if we have MT-safe variant of getgrnam() and if yes,
# which one exactly.
#
# Arguments:
# None
#
# Results:
#
# Might define the following vars:
# HAVE_GETGRNAM_R
# HAVE_GETGRNAM_R_4
# HAVE_GETGRNAM_R_5
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETGRNAM_R], [AC_CHECK_FUNC(getgrnam_r, [
AC_CACHE_CHECK([for getgrnam_r with 5 args], tcl_cv_api_getgrnam_r_5, [
AC_TRY_COMPILE([
#include <sys/types.h>
#include <grp.h>
], [
char *name;
struct group gr, *grp;
char buf[512];
int buflen = 512;
(void) getgrnam_r(name, &gr, buf, buflen, &grp);
], tcl_cv_api_getgrnam_r_5=yes, tcl_cv_api_getgrnam_r_5=no)])
tcl_ok=$tcl_cv_api_getgrnam_r_5
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRNAM_R_5)
else
AC_CACHE_CHECK([for getgrnam_r with 4 args], tcl_cv_api_getgrnam_r_4, [
AC_TRY_COMPILE([
#include <sys/types.h>
#include <grp.h>
], [
char *name;
struct group gr;
char buf[512];
int buflen = 512;
(void)getgrnam_r(name, &gr, buf, buflen);
], tcl_cv_api_getgrnam_r_4=yes, tcl_cv_api_getgrnam_r_4=no)])
tcl_ok=$tcl_cv_api_getgrnam_r_4
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRNAM_R_4)
fi
fi
if test "$tcl_ok" = yes; then
AC_DEFINE(HAVE_GETGRNAM_R)
fi
])])
#--------------------------------------------------------------------
# SC_CONFIG_COMMANDS_PRE(CMDS)
#
# Replacement for autoconf 2.5x AC_COMMANDS_PRE:
# Commands to run right before config.status is
# created. Accumulates.
#
# Requires presence of SC_OUTPUT_COMMANDS_PRE at the end
# of configure.in (right before AC_OUTPUT).
#
#--------------------------------------------------------------------
AC_DEFUN([SC_CONFIG_COMMANDS_PRE], [
define([SC_OUTPUT_COMMANDS_PRE], defn([SC_OUTPUT_COMMANDS_PRE])[$1
])])
AC_DEFUN([SC_OUTPUT_COMMANDS_PRE])
|
Changes to unix/tcl.spec.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 |
# $Id: tcl.spec,v 1.16.2.16 2007/05/30 14:05:21 dgp Exp $
# This file is the basis for a binary Tcl RPM for Linux.
%define version 8.4.16
%define directory /usr/local
Summary: Tcl scripting language development environment
Name: tcl
Version: %{version}
Release: 1
Copyright: BSD
|
| ︙ | ︙ |
Changes to unix/tclConfig.sh.in.
1 2 3 4 5 6 7 8 9 10 11 | # tclConfig.sh -- # # This shell script (for sh) is generated automatically by Tcl's # configure script. It will create shell variables for most of # the configuration options discovered by the configure script. # This script is intended to be included by the configure scripts # for Tcl extensions so that they don't have to figure this all # out for themselves. # # The information in this file is specific to a single platform. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | # tclConfig.sh -- # # This shell script (for sh) is generated automatically by Tcl's # configure script. It will create shell variables for most of # the configuration options discovered by the configure script. # This script is intended to be included by the configure scripts # for Tcl extensions so that they don't have to figure this all # out for themselves. # # The information in this file is specific to a single platform. # # RCS: @(#) $Id: tclConfig.sh.in,v 1.17.2.1 2004/07/20 11:13:10 das Exp $ # Tcl's version number. TCL_VERSION='@TCL_VERSION@' TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@' TCL_MINOR_VERSION='@TCL_MINOR_VERSION@' TCL_PATCH_LEVEL='@TCL_PATCH_LEVEL@' |
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | # Flags to pass to cc when compiling the components of a shared library: TCL_SHLIB_CFLAGS='@SHLIB_CFLAGS@' # Flags to pass to cc to get warning messages TCL_CFLAGS_WARNING='@CFLAGS_WARNING@' # Extra flags to pass to cc: | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | # Flags to pass to cc when compiling the components of a shared library: TCL_SHLIB_CFLAGS='@SHLIB_CFLAGS@' # Flags to pass to cc to get warning messages TCL_CFLAGS_WARNING='@CFLAGS_WARNING@' # Extra flags to pass to cc: TCL_EXTRA_CFLAGS='@CFLAGS@' # Base command to use for combining object files into a shared library: TCL_SHLIB_LD='@SHLIB_LD@' # Base command to use for combining object files into a static library: TCL_STLIB_LD='@STLIB_LD@' |
| ︙ | ︙ |
Changes to unix/tclLoadDl.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclLoadDl.c -- * * This procedure provides a version of the TclLoadFile that * works with the "dlopen" and "dlsym" library procedures for * dynamic loading. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclLoadDl.c -- * * This procedure provides a version of the TclLoadFile that * works with the "dlopen" and "dlsym" library procedures for * dynamic loading. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclLoadDl.c,v 1.13.2.1 2006/06/13 22:54:01 dkf Exp $ */ #include "tclInt.h" #ifdef NO_DLFCN_H # include "../compat/dlfcn.h" #else # include <dlfcn.h> |
| ︙ | ︙ | |||
86 87 88 89 90 91 92 93 |
char *fileName = Tcl_GetString(pathPtr);
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
Tcl_AppendResult(interp, "couldn't load file \"",
| > > > > > > > | < | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
char *fileName = Tcl_GetString(pathPtr);
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
/*
* Write the string to a variable first to work around a compiler bug
* in the Sun Forte 6 compiler. [Bug 1503729]
*/
CONST char *errorStr = dlerror();
Tcl_AppendResult(interp, "couldn't load file \"",
Tcl_GetString(pathPtr), "\": ", errorStr, (char *) NULL);
return TCL_ERROR;
}
*unloadProcPtr = &TclpUnloadFile;
*loadHandle = (Tcl_LoadHandle)handle;
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to unix/tclLoadDyld.c.
|
| | | | > | < > | | | > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | > > | | | | > < < | | | > > > > > > > | | | | | > | | > | | | | | > > | > > > > > > > | > | | > | < > | > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | > | | | | | | > | > > | | | | > > > > > > > | | > > > > > > > | | | | | | > > | | > | > | | > > > > > > > | | | | | | | | > | | | | | < | > > | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
/*
* tclLoadDyld.c --
*
* This procedure provides a version of the TclLoadFile that works with
* Apple's dyld dynamic loading.
* Original version of his file (now superseded long ago) provided by
* Wilfredo Sanchez (wsanchez@apple.com).
*
* Copyright (c) 1995 Apple Computer, Inc.
* Copyright (c) 2001-2007 Daniel A. Steffen <das@users.sourceforge.net>
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclLoadDyld.c,v 1.14.2.9 2007/04/29 02:20:16 das Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include <mach-o/dyld.h>
#include <mach-o/fat.h>
#include <mach-o/swap.h>
#include <mach-o/arch.h>
#include <libkern/OSByteOrder.h>
#undef panic
#include <mach/mach.h>
#ifndef MODULE_SCOPE
#define MODULE_SCOPE extern
#endif
typedef struct Tcl_DyldModuleHandle {
struct Tcl_DyldModuleHandle *nextPtr;
NSModule module;
} Tcl_DyldModuleHandle;
typedef struct Tcl_DyldLoadHandle {
CONST struct mach_header *dyldLibHeader;
Tcl_DyldModuleHandle *modulePtr;
} Tcl_DyldLoadHandle;
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE long tclMacOSXDarwinRelease;
#endif
/*
*----------------------------------------------------------------------
*
* DyldOFIErrorMsg --
*
* Converts a numerical NSObjectFileImage error into an error message
* string.
*
* Results:
* Error message string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static CONST char*
DyldOFIErrorMsg(
int err)
{
switch(err) {
case NSObjectFileImageSuccess:
return NULL;
case NSObjectFileImageFailure:
return "object file setup failure";
case NSObjectFileImageInappropriateFile:
return "not a Mach-O MH_BUNDLE file";
case NSObjectFileImageArch:
return "no object for this architecture";
case NSObjectFileImageFormat:
return "bad object file format";
case NSObjectFileImageAccess:
return "can't read object file";
default:
return "unknown error";
}
}
/*
*----------------------------------------------------------------------
*
* TclpDlopen --
*
* Dynamically loads a binary code file into memory and returns a handle
* to the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error message
* is left in the interpreter's result.
*
* Side effects:
* New code suddenly appears in memory.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE int
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr)
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
{
Tcl_DyldLoadHandle *dyldLoadHandle;
CONST struct mach_header *dyldLibHeader;
NSObjectFileImage dyldObjFileImage = NULL;
Tcl_DyldModuleHandle *modulePtr = NULL;
CONST char *native;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
native = Tcl_FSGetNativePath(pathPtr);
dyldLibHeader = NSAddImage(native, NSADDIMAGE_OPTION_RETURN_ON_ERROR);
if (!dyldLibHeader) {
NSLinkEditErrors editError;
int errorNumber;
CONST char *name, *msg, *objFileImageErrMsg = NULL;
NSLinkEditError(&editError, &errorNumber, &name, &msg);
if (editError == NSLinkEditFileAccessError) {
/*
* The requested file was not found. Let the OS loader examine the
* binary search path for whatever string the user gave us which
* hopefully refers to a file on the binary path.
*/
Tcl_DString ds;
char *fileName = Tcl_GetString(pathPtr);
CONST char *native =
Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
dyldLibHeader = NSAddImage(native, NSADDIMAGE_OPTION_WITH_SEARCHING
| NSADDIMAGE_OPTION_RETURN_ON_ERROR);
Tcl_DStringFree(&ds);
if (!dyldLibHeader) {
NSLinkEditError(&editError, &errorNumber, &name, &msg);
}
} else if ((editError == NSLinkEditFileFormatError
&& errorNumber == EBADMACHO)
|| editError == NSLinkEditOtherError){
/*
* The requested file was found but was not of type MH_DYLIB,
* attempt to load it as a MH_BUNDLE.
*/
NSObjectFileImageReturnCode err =
NSCreateObjectFileImageFromFile(native, &dyldObjFileImage);
objFileImageErrMsg = DyldOFIErrorMsg(err);
}
if (!dyldLibHeader && !dyldObjFileImage) {
Tcl_AppendResult(interp, msg, NULL);
if (msg && *msg) {
Tcl_AppendResult(interp, "\n", NULL);
}
if (objFileImageErrMsg) {
Tcl_AppendResult(interp,
"NSCreateObjectFileImageFromFile() error: ",
objFileImageErrMsg, NULL);
}
return TCL_ERROR;
}
}
if (dyldObjFileImage) {
NSModule module;
module = NSLinkModule(dyldObjFileImage, native,
NSLINKMODULE_OPTION_BINDNOW
| NSLINKMODULE_OPTION_RETURN_ON_ERROR);
NSDestroyObjectFileImage(dyldObjFileImage);
if (!module) {
NSLinkEditErrors editError;
int errorNumber;
CONST char *name, *msg;
NSLinkEditError(&editError, &errorNumber, &name, &msg);
Tcl_AppendResult(interp, msg, NULL);
return TCL_ERROR;
}
modulePtr = (Tcl_DyldModuleHandle *)
ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
}
dyldLoadHandle = (Tcl_DyldLoadHandle *)
ckalloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dyldLibHeader = dyldLibHeader;
dyldLoadHandle->modulePtr = modulePtr;
*loadHandle = (Tcl_LoadHandle) dyldLoadHandle;
*unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclpFindSymbol --
*
* Looks up a symbol, by name, through a handle associated with a
* previously loaded piece of code (shared library).
*
* Results:
* Returns a pointer to the function associated with 'symbol' if it is
* found. Otherwise returns NULL and may leave an error message in the
* interp's result.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE Tcl_PackageInitProc *
TclpFindSymbol(
Tcl_Interp *interp, /* For error reporting. */
Tcl_LoadHandle loadHandle, /* Handle from TclpDlopen. */
CONST char *symbol) /* Symbol name to look up. */
{
NSSymbol nsSymbol;
CONST char *native;
Tcl_DString newName, ds;
Tcl_PackageInitProc *proc = NULL;
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;
/*
* dyld adds an underscore to the beginning of symbol names.
*/
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
Tcl_DStringInit(&newName);
Tcl_DStringAppend(&newName, "_", 1);
native = Tcl_DStringAppend(&newName, native, -1);
if (dyldLoadHandle->dyldLibHeader) {
nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyldLibHeader, native,
NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW |
NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
if (nsSymbol) {
/*
* Until dyld supports unloading of MY_DYLIB binaries, the
* following is not needed.
*/
#ifdef DYLD_SUPPORTS_DYLIB_UNLOADING
NSModule module = NSModuleForSymbol(nsSymbol);
Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;
while (modulePtr != NULL) {
if (module == modulePtr->module) {
break;
}
modulePtr = modulePtr->nextPtr;
}
if (modulePtr == NULL) {
modulePtr = (Tcl_DyldModuleHandle *)
ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = dyldLoadHandle->modulePtr;
dyldLoadHandle->modulePtr = modulePtr;
}
#endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */
} else {
NSLinkEditErrors editError;
int errorNumber;
CONST char *name, *msg;
NSLinkEditError(&editError, &errorNumber, &name, &msg);
Tcl_AppendResult(interp, msg, NULL);
}
} else {
nsSymbol = NSLookupSymbolInModule(dyldLoadHandle->modulePtr->module,
native);
}
if (nsSymbol) {
proc = NSAddressOfSymbol(nsSymbol);
}
Tcl_DStringFree(&newName);
Tcl_DStringFree(&ds);
return proc;
}
/*
*----------------------------------------------------------------------
*
* TclpUnloadFile --
*
* Unloads a dynamically loaded binary code file from memory. Code
* pointers in the formerly loaded file are no longer valid after calling
* this function.
*
* Results:
* None.
*
* Side effects:
* Code dissapears from memory. Note that dyld currently only supports
* unloading of binaries of type MH_BUNDLE loaded with NSLinkModule() in
* TclpDlopen() above.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE void
TclpUnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *) loadHandle;
Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;
while (modulePtr != NULL) {
void *ptr;
NSUnLinkModule(modulePtr->module,
NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES);
ptr = modulePtr;
modulePtr = modulePtr->nextPtr;
ckfree(ptr);
}
ckfree((char*) dyldLoadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
* If the "load" command is invoked without providing a package name,
* this procedure is invoked to try to figure it out.
*
* Results:
* Always returns 0 to indicate that we couldn't figure out a package
* name; generic code will then try to guess the package from the file
* name. A return value of 1 would have meant that we figured out the
* package name and put it in bufPtr.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclGuessPackageName(
CONST char *fileName, /* Name of file containing package (already
* translated to local form if needed). */
Tcl_DString *bufPtr) /* Initialized empty dstring. Append package
* name to this if possible. */
{
return 0;
}
#ifdef TCL_LOAD_FROM_MEMORY
/*
*----------------------------------------------------------------------
*
* TclpLoadMemoryGetBuffer --
*
* Allocate a buffer that can be used with TclpLoadMemory() below.
*
* Results:
* Pointer to allocated buffer or NULL if an error occurs.
*
* Side effects:
* Buffer is allocated.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
Tcl_Interp *interp, /* Used for error reporting. */
int size) /* Size of desired buffer. */
{
void *buffer = NULL;
/*
* NSCreateObjectFileImageFromMemory is available but always fails
* prior to Darwin 7.
*/
if (tclMacOSXDarwinRelease >= 7) {
/*
* We must allocate the buffer using vm_allocate, because
* NSCreateObjectFileImageFromMemory will dispose of it using
* vm_deallocate.
*/
if (vm_allocate(mach_task_self(), (vm_address_t *) &buffer, size, 1)) {
buffer = NULL;
}
}
return buffer;
}
/*
*----------------------------------------------------------------------
*
* TclpLoadMemory --
*
* Dynamically loads binary code file from memory and returns a handle to
* the new code.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error message
* is left in the interpreter's result.
*
* Side effects:
* New code is loaded from memory.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE int
TclpLoadMemory(
Tcl_Interp *interp, /* Used for error reporting. */
void *buffer, /* Buffer containing the desired code
* (allocated with TclpLoadMemoryGetBuffer). */
int size, /* Allocation size of buffer. */
int codeSize, /* Size of code data read into buffer or -1 if
* an error occurred and the buffer should
* just be freed. */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr)
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
{
Tcl_DyldLoadHandle *dyldLoadHandle;
NSObjectFileImage dyldObjFileImage = NULL;
Tcl_DyldModuleHandle *modulePtr;
NSModule module;
CONST char *objFileImageErrMsg = NULL;
/*
* Try to create an object file image that we can load from.
*/
if (codeSize >= 0) {
NSObjectFileImageReturnCode err = NSObjectFileImageSuccess;
CONST struct fat_header *fh = buffer;
uint32_t ms = 0;
#ifndef __LP64__
CONST struct mach_header *mh = NULL;
#define mh_magic OSSwapHostToBigInt32(MH_MAGIC)
#define mh_size sizeof(struct mach_header)
#else
CONST struct mach_header_64 *mh = NULL;
#define mh_magic OSSwapHostToBigInt32(MH_MAGIC_64)
#define mh_size sizeof(struct mach_header_64)
#endif
if ((size_t) codeSize >= sizeof(struct fat_header)
&& fh->magic == OSSwapHostToBigInt32(FAT_MAGIC)) {
/*
* Fat binary, try to find mach_header for our architecture
*/
uint32_t fh_nfat_arch = OSSwapBigToHostInt32(fh->nfat_arch);
if ((size_t) codeSize >= sizeof(struct fat_header) +
fh_nfat_arch * sizeof(struct fat_arch)) {
void *fatarchs = (char*)buffer + sizeof(struct fat_header);
CONST NXArchInfo *arch = NXGetLocalArchInfo();
struct fat_arch *fa;
if (fh->magic != FAT_MAGIC) {
swap_fat_arch(fatarchs, fh_nfat_arch, arch->byteorder);
}
fa = NXFindBestFatArch(arch->cputype, arch->cpusubtype,
fatarchs, fh_nfat_arch);
if (fa) {
mh = (void*)((char*)buffer + fa->offset);
ms = fa->size;
} else {
err = NSObjectFileImageInappropriateFile;
}
if (fh->magic != FAT_MAGIC) {
swap_fat_arch(fatarchs, fh_nfat_arch, arch->byteorder);
}
} else {
err = NSObjectFileImageInappropriateFile;
}
} else {
/*
* Thin binary
*/
mh = buffer;
ms = codeSize;
}
if (ms && !(ms >= mh_size && mh->magic == mh_magic &&
mh->filetype == OSSwapHostToBigInt32(MH_BUNDLE))) {
err = NSObjectFileImageInappropriateFile;
}
if (err == NSObjectFileImageSuccess) {
err = NSCreateObjectFileImageFromMemory(buffer, codeSize,
&dyldObjFileImage);
}
objFileImageErrMsg = DyldOFIErrorMsg(err);
}
/*
* If it went wrong (or we were asked to just deallocate), get rid of the
* memory block and create an error message.
*/
if (dyldObjFileImage == NULL) {
vm_deallocate(mach_task_self(), (vm_address_t) buffer, size);
if (objFileImageErrMsg != NULL) {
Tcl_AppendResult(interp,
"NSCreateObjectFileImageFromMemory() error: ",
objFileImageErrMsg, NULL);
}
return TCL_ERROR;
}
/*
* Extract the module we want from the image of the object file.
*/
module = NSLinkModule(dyldObjFileImage, "[Memory Based Bundle]",
NSLINKMODULE_OPTION_BINDNOW | NSLINKMODULE_OPTION_RETURN_ON_ERROR);
NSDestroyObjectFileImage(dyldObjFileImage);
if (!module) {
NSLinkEditErrors editError;
int errorNumber;
CONST char *name, *msg;
NSLinkEditError(&editError, &errorNumber, &name, &msg);
Tcl_AppendResult(interp, msg, NULL);
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
modulePtr = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
dyldLoadHandle = (Tcl_DyldLoadHandle *)
ckalloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dyldLibHeader = NULL;
dyldLoadHandle->modulePtr = modulePtr;
*loadHandle = (Tcl_LoadHandle) dyldLoadHandle;
*unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclLoadShl.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclLoadShl.c -- * * This procedure provides a version of the TclLoadFile that works * with the "shl_load" and "shl_findsym" library procedures for * dynamic loading (e.g. for HP machines). * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclLoadShl.c -- * * This procedure provides a version of the TclLoadFile that works * with the "shl_load" and "shl_findsym" library procedures for * dynamic loading (e.g. for HP machines). * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclLoadShl.c,v 1.13.2.1 2005/10/05 04:23:56 hobbs Exp $ */ #include <dl.h> /* * On some HP machines, dl.h defines EXTERN; remove that definition. */ |
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
* and allows to load libtk8.0.sl into tclsh8.0 without problems.
* In general, this delays resolving symbols until they are actually
* needed. Shared libs do no longer need all libraries linked in
* when they are build."
*/
| | | < | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
* and allows to load libtk8.0.sl into tclsh8.0 without problems.
* In general, this delays resolving symbols until they are actually
* needed. Shared libs do no longer need all libraries linked in
* when they are build."
*/
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load
* using a relative path.
*/
native = Tcl_FSGetNativePath(pathPtr);
handle = shl_load(native, BIND_DEFERRED|BIND_VERBOSE, 0L);
if (handle == NULL) {
/*
* Let the OS loader examine the binary search path for
* whatever string the user gave us which hopefully refers
* to a file on the binary path
*/
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
handle = shl_load(native,
|
| ︙ | ︙ |
Changes to unix/tclUnixChan.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclUnixChan.c * * Common channel driver for Unix channels based on files, command * pipes and TCP sockets. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclUnixChan.c * * Common channel driver for Unix channels based on files, command * pipes and TCP sockets. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUnixChan.c,v 1.42.2.10 2006/11/28 16:29:48 kennykb Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclPort.h" /* Portability features for Tcl. */ #include "tclIO.h" /* To get Channel type declaration. */ /* |
| ︙ | ︙ | |||
246 247 248 249 250 251 252 253 254 255 256 257 258 259 | static int FileInputProc _ANSI_ARGS_((ClientData instanceData, char *buf, int toRead, int *errorCode)); static int FileOutputProc _ANSI_ARGS_(( ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCode)); static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode)); static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); static int TcpBlockModeProc _ANSI_ARGS_((ClientData data, int mode)); | > > > > | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | static int FileInputProc _ANSI_ARGS_((ClientData instanceData, char *buf, int toRead, int *errorCode)); static int FileOutputProc _ANSI_ARGS_(( ClientData instanceData, CONST char *buf, int toWrite, int *errorCode)); static int FileSeekProc _ANSI_ARGS_((ClientData instanceData, long offset, int mode, int *errorCode)); #ifdef DEPRECATED static void FileThreadActionProc _ANSI_ARGS_ (( ClientData instanceData, int action)); #endif static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode)); static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); static void TcpAccept _ANSI_ARGS_((ClientData data, int mask)); static int TcpBlockModeProc _ANSI_ARGS_((ClientData data, int mode)); |
| ︙ | ︙ | |||
301 302 303 304 305 306 307 |
/*
* This structure describes the channel type structure for file based IO:
*/
static Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
| | > > > > > | > > | > > | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
/*
* This structure describes the channel type structure for file based IO:
*/
static Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
FileCloseProc, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
FileSeekProc, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
NULL, /* close2proc. */
FileBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
FileWideSeekProc, /* wide seek proc. */
#ifdef DEPRECATED
FileThreadActionProc, /* thread actions */
#else
NULL,
#endif
};
#ifdef SUPPORTS_TTY
/*
* This structure describes the channel type structure for serial IO.
* Note that this type is a subclass of the "file" type.
*/
static Tcl_ChannelType ttyChannelType = {
"tty", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
TtyCloseProc, /* Close proc. */
FileInputProc, /* Input proc. */
#if BAD_TIP35_FLUSH
TtyOutputProc, /* Output proc. */
#else /* !BAD_TIP35_FLUSH */
FileOutputProc, /* Output proc. */
#endif /* BAD_TIP35_FLUSH */
NULL, /* Seek proc. */
TtySetOptionProc, /* Set option proc. */
TtyGetOptionProc, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
NULL, /* close2proc. */
FileBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
NULL, /* thread action proc. */
};
#endif /* SUPPORTS_TTY */
/*
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
TcpCloseProc, /* Close proc. */
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
TcpGetOptionProc, /* Get option proc. */
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
NULL, /* close2proc. */
TcpBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
NULL, /* thread action proc. */
};
/*
*----------------------------------------------------------------------
*
* FileBlockModeProc --
|
| ︙ | ︙ | |||
965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 |
iostate.c_cc[VSTOP] = argv[1][0];
} else {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -xchar: should be a list of two elements",
(char *) NULL);
}
return TCL_ERROR;
}
SETIOSTATE(fsPtr->fd, &iostate);
return TCL_OK;
}
/*
* Option -timeout msec
*/
if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
| > > | 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 |
iostate.c_cc[VSTOP] = argv[1][0];
} else {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -xchar: should be a list of two elements",
(char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
}
SETIOSTATE(fsPtr->fd, &iostate);
ckfree((char *) argv);
return TCL_OK;
}
/*
* Option -timeout msec
*/
if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
|
| ︙ | ︙ | |||
991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 |
return TCL_OK;
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -ttycontrol: should be a list of",
"signal,value pairs", (char *) NULL);
}
return TCL_ERROR;
}
GETCONTROL(fsPtr->fd, &control);
| > > | | > | > | > | > | | > < | > | 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 |
return TCL_OK;
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
int i;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -ttycontrol: should be a list of",
"signal,value pairs", (char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
}
GETCONTROL(fsPtr->fd, &control);
for (i = 0; i < argc-1; i += 2) {
if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
ckfree((char *) argv);
return TCL_ERROR;
}
if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) {
#ifdef TIOCM_DTR
if (flag) {
control |= TIOCM_DTR;
} else {
control &= ~TIOCM_DTR;
}
#else /* !TIOCM_DTR */
UNSUPPORTED_OPTION("-ttycontrol DTR");
ckfree((char *) argv);
return TCL_ERROR;
#endif /* TIOCM_DTR */
} else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) {
#ifdef TIOCM_RTS
if (flag) {
control |= TIOCM_RTS;
} else {
control &= ~TIOCM_RTS;
}
#else /* !TIOCM_RTS*/
UNSUPPORTED_OPTION("-ttycontrol RTS");
ckfree((char *) argv);
return TCL_ERROR;
#endif /* TIOCM_RTS*/
} else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
#ifdef SETBREAK
SETBREAK(fsPtr->fd, flag);
#else /* !SETBREAK */
UNSUPPORTED_OPTION("-ttycontrol BREAK");
ckfree((char *) argv);
return TCL_ERROR;
#endif /* SETBREAK */
} else {
if (interp) {
Tcl_AppendResult(interp, "bad signal \"", argv[i],
"\" for -ttycontrol: must be ",
"DTR, RTS or BREAK", (char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
}
} /* -ttycontrol options loop */
SETCONTROL(fsPtr->fd, &control);
ckfree((char *) argv);
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"mode handshake timeout ttycontrol xchar ");
#else /* !USE_TERMIOS */
|
| ︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 |
translation = NULL;
channelTypePtr = &fileChannelType;
fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
}
#ifdef DEPRECATED
if (channelTypePtr == &fileChannelType) {
| > > > > | < | 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 |
translation = NULL;
channelTypePtr = &fileChannelType;
fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
}
#ifdef DEPRECATED
if (channelTypePtr == &fileChannelType) {
/* TIP #218. Removed the code inserting the new structure
* into the global list. This is now handled in the thread
* action callbacks, and only there.
*/
fsPtr->nextPtr = NULL;
}
#endif /* DEPRECATED */
fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
fsPtr->fd = fd;
fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
(ClientData) fsPtr, channelPermissions);
|
| ︙ | ︙ | |||
1885 1886 1887 1888 1889 1890 1891 |
FileState *fsPtr;
char channelName[16 + TCL_INTEGER_SPACE];
int fd = (int) handle;
Tcl_ChannelType *channelTypePtr;
#ifdef DEPRECATED
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif /* DEPRECATED */
| | | > > | | > | | | | | 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 |
FileState *fsPtr;
char channelName[16 + TCL_INTEGER_SPACE];
int fd = (int) handle;
Tcl_ChannelType *channelTypePtr;
#ifdef DEPRECATED
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif /* DEPRECATED */
struct sockaddr sockaddr;
socklen_t sockaddrLen = sizeof(sockaddr);
if (mode == 0) {
return NULL;
}
/*
* Look to see if a channel with this fd and the same mode already exists.
* If the fd is used, but the mode doesn't match, return NULL.
*/
#ifdef DEPRECATED
for (fsPtr = tsdPtr->firstFilePtr; fsPtr != NULL; fsPtr = fsPtr->nextPtr) {
if (fsPtr->fd == fd) {
return ((mode|TCL_EXCEPTION) == fsPtr->validMask) ?
fsPtr->channel : NULL;
}
}
#endif /* DEPRECATED */
sockaddr.sa_family = AF_UNSPEC;
#ifdef SUPPORTS_TTY
if (isatty(fd)) {
fsPtr = TtyInit(fd, 0);
channelTypePtr = &ttyChannelType;
sprintf(channelName, "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
if (getsockname(fd, (struct sockaddr *)&sockaddr, &sockaddrLen) == 0
&& sockaddrLen > 0
&& sockaddr.sa_family == AF_INET) {
return MakeTcpClientChannelMode((ClientData) fd, mode);
} else {
channelTypePtr = &fileChannelType;
fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
sprintf(channelName, "file%d", fd);
}
#ifdef DEPRECATED
if (channelTypePtr == &fileChannelType) {
fsPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = fsPtr;
}
|
| ︙ | ︙ | |||
2274 2275 2276 2277 2278 2279 2280 |
if (getpeername(statePtr->fd, (struct sockaddr *) &peername,
&size) >= 0) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringStartSublist(dsPtr);
}
Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr));
| | | > | 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 |
if (getpeername(statePtr->fd, (struct sockaddr *) &peername,
&size) >= 0) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-peername");
Tcl_DStringStartSublist(dsPtr);
}
Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr));
hostEntPtr = TclpGetHostByAddr( /* INTL: Native. */
(char *) &peername.sin_addr,
sizeof(peername.sin_addr), AF_INET);
if (hostEntPtr != (struct hostent *) NULL) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, hostEntPtr->h_name, -1, &ds);
Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
} else {
Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr));
}
TclFormatInt(buf, ntohs(peername.sin_port));
Tcl_DStringAppendElement(dsPtr, buf);
if (len == 0) {
Tcl_DStringEndSublist(dsPtr);
|
| ︙ | ︙ | |||
2320 2321 2322 2323 2324 2325 2326 |
if (getsockname(statePtr->fd, (struct sockaddr *) &sockname,
&size) >= 0) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-sockname");
Tcl_DStringStartSublist(dsPtr);
}
Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
| | > | 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 |
if (getsockname(statePtr->fd, (struct sockaddr *) &sockname,
&size) >= 0) {
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-sockname");
Tcl_DStringStartSublist(dsPtr);
}
Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
hostEntPtr = TclpGetHostByAddr( /* INTL: Native. */
(char *) &sockname.sin_addr,
sizeof(sockname.sin_addr), AF_INET);
if (hostEntPtr != (struct hostent *) NULL) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, hostEntPtr->h_name, -1, &ds);
Tcl_DStringAppendElement(dsPtr, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
} else {
Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr));
}
TclFormatInt(buf, ntohs(sockname.sin_port));
Tcl_DStringAppendElement(dsPtr, buf);
if (len == 0) {
Tcl_DStringEndSublist(dsPtr);
|
| ︙ | ︙ | |||
2652 2653 2654 2655 2656 2657 2658 |
}
addr.s_addr = inet_addr(native); /* INTL: Native. */
/*
* This is 0xFFFFFFFF to ensure that it compares as a 32bit -1
* on either 32 or 64 bits systems.
*/
if (addr.s_addr == 0xFFFFFFFF) {
| | | | 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 |
}
addr.s_addr = inet_addr(native); /* INTL: Native. */
/*
* This is 0xFFFFFFFF to ensure that it compares as a 32bit -1
* on either 32 or 64 bits systems.
*/
if (addr.s_addr == 0xFFFFFFFF) {
hostent = TclpGetHostByName(native); /* INTL: Native. */
if (hostent != (struct hostent *) NULL) {
memcpy((VOID *) &addr,
(VOID *) hostent->h_addr_list[0],
(size_t) hostent->h_length);
} else {
#ifdef EHOSTUNREACH
errno = EHOSTUNREACH;
#else /* !EHOSTUNREACH */
|
| ︙ | ︙ | |||
3149 3150 3151 3152 3153 3154 3155 |
* TCL_EXCEPTION. */
int timeout; /* Maximum amount of time to wait for one
* of the conditions in mask to occur, in
* milliseconds. A value of 0 means don't
* wait at all, and a value of -1 means
* wait forever. */
{
| | | > | 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 |
* TCL_EXCEPTION. */
int timeout; /* Maximum amount of time to wait for one
* of the conditions in mask to occur, in
* milliseconds. A value of 0 means don't
* wait at all, and a value of -1 means
* wait forever. */
{
Tcl_Time abortTime = {0, 0}, now; /* silence gcc 4 warning */
struct timeval blockTime, *timeoutPtr;
int index, numFound, result = 0;
fd_mask bit;
fd_mask readyMasks[3*MASK_SIZE];
/* This array reflects the readable/writable
* conditions that were found to exist by the
* last call to select. */
/*
* If there is a non-zero finite timeout, compute the time when
|
| ︙ | ︙ | |||
3188 3189 3190 3191 3192 3193 3194 |
*/
if (fd >= FD_SETSIZE) {
panic("TclWaitForFile can't handle file id %d", fd);
}
memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask));
index = fd/(NBBY*sizeof(fd_mask));
| | | 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 |
*/
if (fd >= FD_SETSIZE) {
panic("TclWaitForFile can't handle file id %d", fd);
}
memset((VOID *) readyMasks, 0, 3*MASK_SIZE*sizeof(fd_mask));
index = fd/(NBBY*sizeof(fd_mask));
bit = ((fd_mask) 1) << (fd%(NBBY*sizeof(fd_mask)));
/*
* Loop in a mini-event loop of our own, waiting for either the
* file to become ready or a timeout to occur.
*/
while (1) {
|
| ︙ | ︙ | |||
3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 |
if (result) {
break;
}
}
if (timeout == 0) {
break;
}
/*
* The select returned early, so we need to recompute the timeout.
*/
Tcl_GetTime(&now);
if ((abortTime.sec < now.sec)
|| ((abortTime.sec == now.sec)
&& (abortTime.usec <= now.usec))) {
break;
}
}
return result;
}
/*
*----------------------------------------------------------------------
*
| > > > > | | < | | < | | < < | > > > > > | | < < < < < | | | | | | | | | | | | | | | | < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 |
if (result) {
break;
}
}
if (timeout == 0) {
break;
}
if (timeout < 0) {
continue;
}
/*
* The select returned early, so we need to recompute the timeout.
*/
Tcl_GetTime(&now);
if ((abortTime.sec < now.sec)
|| ((abortTime.sec == now.sec)
&& (abortTime.usec <= now.usec))) {
break;
}
}
return result;
}
#ifdef DEPRECATED
/*
*----------------------------------------------------------------------
*
* FileThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
FileThreadActionProc (instanceData, action)
ClientData instanceData;
int action;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileState *fsPtr = (FileState *) instanceData;
if (action == TCL_CHANNEL_THREAD_INSERT) {
fsPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = fsPtr;
} else {
FileState **nextPtrPtr;
int removed = 0;
for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == fsPtr) {
(*nextPtrPtr) = fsPtr->nextPtr;
removed = 1;
break;
}
}
/*
* This could happen if the channel was created in one
* thread and then moved to another without updating
* the thread local data in each thread.
*/
if (!removed) {
panic("file info ptr not on thread channel list");
}
}
}
#endif /* DEPRECATED */
|
Added unix/tclUnixCompat.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 |
/*
* tclUnixCompat.c
*
* Written by: Zoran Vasiljevic (vasiljevic@users.sourceforge.net).
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclUnixCompat.c,v 1.1.2.10 2006/09/12 22:05:03 andreas_kupries Exp $
*
*/
#include "tclInt.h"
#include "tclPort.h"
#include <pwd.h>
#include <grp.h>
#include <errno.h>
#include <string.h>
/*
* Used to pad structures at size'd boundaries
*
* This macro assumes that the pointer 'buffer' was created from an
* aligned pointer by adding the 'length'. If this 'length' was not a
* multiple of the 'size' the result is unaligned and PadBuffer
* corrects both the pointer, _and_ the 'length'. The latter means
* that future increments of 'buffer' by 'length' stay aligned.
*/
#define PadBuffer(buffer, length, size) \
if (((length) % (size))) { \
(buffer) += ((size) - ((length) % (size))); \
(length) += ((size) - ((length) % (size))); \
}
/*
* Per-thread private storage used to store values
* returned from MT-unsafe library calls.
*/
#ifdef TCL_THREADS
typedef struct ThreadSpecificData {
struct passwd pwd;
char pbuf[2048];
struct group grp;
char gbuf[2048];
#if !defined(HAVE_MTSAFE_GETHOSTBYNAME) || !defined(HAVE_MTSAFE_GETHOSTBYADDR)
struct hostent hent;
char hbuf[2048];
#endif
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#if ((!defined(HAVE_GETHOSTBYNAME_R) || !defined(HAVE_GETHOSTBYADDR_R)) && \
(!defined(HAVE_MTSAFE_GETHOSTBYNAME) || !defined(HAVE_MTSAFE_GETHOSTBYADDR))) || \
!defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R) || \
!defined(HAVE_GETGRNAM_R) || !defined(HAVE_GETGRGID_R)
/*
* Mutex to lock access to MT-unsafe calls. This is just to protect
* our own usage. It does not protect us from others calling the
* same functions without (or using some different) lock.
*/
static Tcl_Mutex compatLock;
/*
*---------------------------------------------------------------------------
*
* CopyArray --
*
* Copies array of NULL-terminated or fixed-length strings
* to the private buffer, honouring the size of the buffer.
*
* Results:
* Number of bytes copied on success or -1 on error (errno = ERANGE)
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
CopyArray(char **src, int elsize, char *buf, int buflen)
{
int i, j, len = 0;
char *p, **new;
if (src == NULL) {
return 0;
}
for (i = 0; src[i] != NULL; i++) {
/* Empty loop to count howmany */
}
if ((sizeof(char *)*(i + 1)) > buflen) {
return -1;
}
len = (sizeof(char *)*(i + 1)); /* Leave place for the array */
new = (char **)buf;
p = buf + (sizeof(char *)*(i + 1));
for (j = 0; j < i; j++) {
if (elsize < 0) {
len += strlen(src[j]) + 1;
} else {
len += elsize;
}
if (len > buflen) {
return -1;
}
if (elsize < 0) {
strcpy(p, src[j]);
} else {
memcpy(p, src[j], elsize);
}
new[j] = p;
p = buf + len;
}
new[j] = NULL;
return len;
}
/*
*---------------------------------------------------------------------------
*
* CopyString --
*
* Copies a NULL-terminated string to the private buffer,
* honouring the size of the buffer
*
* Results:
* 0 success or -1 on error (errno = ERANGE)
*
* Side effects:
* None
*
*---------------------------------------------------------------------------
*/
static int
CopyString(char *src, char *buf, int buflen)
{
int len = 0;
if (src != NULL) {
len += strlen(src) + 1;
if (len > buflen) {
return -1;
}
strcpy(buf, src);
}
return len;
}
#endif /* ((!defined(HAVE_GETHOSTBYNAME_R) || !defined(HAVE_GETHOSTBYADDR_R)) && \
(!defined(HAVE_MTSAFE_GETHOSTBYNAME) || !defined(HAVE_MTSAFE_GETHOSTBYADDR))) || \
!defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R) || \
!defined(HAVE_GETGRNAM_R) || !defined(HAVE_GETGRGID_R) */
#if (!defined(HAVE_GETHOSTBYNAME_R) || !defined(HAVE_GETHOSTBYADDR_R)) && \
(!defined(HAVE_MTSAFE_GETHOSTBYNAME) || !defined(HAVE_MTSAFE_GETHOSTBYADDR))
/*
*---------------------------------------------------------------------------
*
* CopyHostnent --
*
* Copies string fields of the hostnent structure to the
* private buffer, honouring the size of the buffer.
*
* Results:
* Number of bytes copied on success or -1 on error (errno = ERANGE)
*
* Side effects:
* None
*
*---------------------------------------------------------------------------
*/
static int
CopyHostent(struct hostent *tgtPtr, char *buf, int buflen)
{
char *p = buf;
int copied, len = 0;
copied = CopyString(tgtPtr->h_name, p, buflen - len);
if (copied == -1) {
range:
errno = ERANGE;
return -1;
}
tgtPtr->h_name = (copied > 0) ? p : NULL;
len += copied;
p = buf + len;
PadBuffer(p, len, sizeof(char *));
copied = CopyArray(tgtPtr->h_aliases, -1, p, buflen - len);
if (copied == -1) {
goto range;
}
tgtPtr->h_aliases = (copied > 0) ? (char **)p : NULL;
len += copied;
p += len;
PadBuffer(p, len, sizeof(char *));
copied = CopyArray(tgtPtr->h_addr_list, tgtPtr->h_length, p, buflen - len);
if (copied == -1) {
goto range;
}
tgtPtr->h_addr_list = (copied > 0) ? (char **)p : NULL;
return 0;
}
#endif /* (!defined(HAVE_GETHOSTBYNAME_R) || !defined(HAVE_GETHOSTBYADDR_R)) && \
(!defined(HAVE_MTSAFE_GETHOSTBYNAME) || !defined(HAVE_MTSAFE_GETHOSTBYADDR)) */
#if !defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R)
/*
*---------------------------------------------------------------------------
*
* CopyPwd --
*
* Copies string fields of the passwd structure to the
* private buffer, honouring the size of the buffer.
*
* Results:
* 0 on success or -1 on error (errno = ERANGE)
*
* Side effects:
* We are not copying the gecos field as it may not be supported
* on all platforms.
*
*---------------------------------------------------------------------------
*/
static int
CopyPwd(struct passwd *tgtPtr, char *buf, int buflen)
{
char *p = buf;
int copied, len = 0;
copied = CopyString(tgtPtr->pw_name, p, buflen - len);
if (copied == -1) {
range:
errno = ERANGE;
return -1;
}
tgtPtr->pw_name = (copied > 0) ? p : NULL;
len += copied;
p = buf + len;
copied = CopyString(tgtPtr->pw_passwd, p, buflen - len);
if (copied == -1) {
goto range;
}
tgtPtr->pw_passwd = (copied > 0) ? p : NULL;
len += copied;
p = buf + len;
copied = CopyString(tgtPtr->pw_dir, p, buflen - len);
if (copied == -1) {
goto range;
}
tgtPtr->pw_dir = (copied > 0) ? p : NULL;
len += copied;
p = buf + len;
copied = CopyString(tgtPtr->pw_shell, p, buflen - len);
if (copied == -1) {
goto range;
}
tgtPtr->pw_shell = (copied > 0) ? p : NULL;
return 0;
}
#endif /* !defined(HAVE_GETPWNAM_R) || !defined(HAVE_GETPWUID_R) */
#if !defined(HAVE_GETGRNAM_R) || !defined(HAVE_GETGRGID_R)
/*
*---------------------------------------------------------------------------
*
* CopyGrp --
*
* Copies string fields of the group structure to the
* private buffer, honouring the size of the buffer.
*
* Results:
* 0 on success or -1 on error (errno = ERANGE)
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static int
CopyGrp(struct group *tgtPtr, char *buf, int buflen)
{
register char *p = buf;
register int copied, len = 0;
/* Copy username */
copied = CopyString(tgtPtr->gr_name, p, buflen - len);
if (copied == -1) {
range:
errno = ERANGE;
return -1;
}
tgtPtr->gr_name = (copied > 0) ? p : NULL;
len += copied;
p = buf + len;
/* Copy password */
copied = CopyString(tgtPtr->gr_passwd, p, buflen - len);
if (copied == -1) {
goto range;
}
tgtPtr->gr_passwd = (copied > 0) ? p : NULL;
len += copied;
p = buf + len;
/* Copy group members */
PadBuffer(p, len, sizeof(char *));
copied = CopyArray((char **)tgtPtr->gr_mem, -1, p, buflen - len);
if (copied == -1) {
goto range;
}
tgtPtr->gr_mem = (copied > 0) ? (char **)p : NULL;
return 0;
}
#endif /* !defined(HAVE_GETGRNAM_R) || !defined(HAVE_GETGRGID_R) */
#endif /* TCL_THREADS */
/*
*---------------------------------------------------------------------------
*
* TclpGetPwNam --
*
* Thread-safe wrappers for getpwnam().
* See "man getpwnam" for more details.
*
* Results:
* Pointer to struct passwd on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct passwd *
TclpGetPwNam(const char *name)
{
#if !defined(TCL_THREADS)
return getpwnam(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETPWNAM_R_5)
struct passwd *pwPtr = NULL;
return (getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf),
&pwPtr) == 0 && pwPtr != NULL) ? &tsdPtr->pwd : NULL;
#elif defined(HAVE_GETPWNAM_R_4)
return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
struct passwd *pwPtr;
Tcl_MutexLock(&compatLock);
pwPtr = getpwnam(name);
if (pwPtr != NULL) {
tsdPtr->pwd = *pwPtr;
pwPtr = &tsdPtr->pwd;
if (CopyPwd(&tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)) == -1) {
pwPtr = NULL;
}
}
Tcl_MutexUnlock(&compatLock);
return pwPtr;
#endif
return NULL; /* Not reached */
#endif /* TCL_THREADS */
}
/*
*---------------------------------------------------------------------------
*
* TclpGetPwUid --
*
* Thread-safe wrappers for getpwuid().
* See "man getpwuid" for more details.
*
* Results:
* Pointer to struct passwd on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct passwd *
TclpGetPwUid(uid_t uid)
{
#if !defined(TCL_THREADS)
return getpwuid(uid);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETPWUID_R_5)
struct passwd *pwPtr = NULL;
return (getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf),
&pwPtr) == 0 && pwPtr != NULL) ? &tsdPtr->pwd : NULL;
#elif defined(HAVE_GETPWUID_R_4)
return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
struct passwd *pwPtr;
Tcl_MutexLock(&compatLock);
pwPtr = getpwuid(uid);
if (pwPtr != NULL) {
tsdPtr->pwd = *pwPtr;
pwPtr = &tsdPtr->pwd;
if (CopyPwd(&tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf)) == -1) {
pwPtr = NULL;
}
}
Tcl_MutexUnlock(&compatLock);
return pwPtr;
#endif
return NULL; /* Not reached */
#endif /* TCL_THREADS */
}
/*
*---------------------------------------------------------------------------
*
* TclpGetGrNam --
*
* Thread-safe wrappers for getgrnam().
* See "man getgrnam" for more details.
*
* Results:
* Pointer to struct group on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct group *
TclpGetGrNam(const char *name)
{
#if !defined(TCL_THREADS)
return getgrnam(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETGRNAM_R_5)
struct group *grPtr = NULL;
return (getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf),
&grPtr) == 0 && grPtr != NULL) ? &tsdPtr->grp : NULL;
#elif defined(HAVE_GETGRNAM_R_4)
return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
struct group *grPtr;
Tcl_MutexLock(&compatLock);
grPtr = getgrnam(name);
if (grPtr != NULL) {
tsdPtr->grp = *grPtr;
grPtr = &tsdPtr->grp;
if (CopyGrp(&tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)) == -1) {
grPtr = NULL;
}
}
Tcl_MutexUnlock(&compatLock);
return grPtr;
#endif
return NULL; /* Not reached */
#endif /* TCL_THREADS */
}
/*
*---------------------------------------------------------------------------
*
* TclpGetGrGid --
*
* Thread-safe wrappers for getgrgid().
* See "man getgrgid" for more details.
*
* Results:
* Pointer to struct group on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct group *
TclpGetGrGid(gid_t gid)
{
#if !defined(TCL_THREADS)
return getgrgid(gid);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETGRGID_R_5)
struct group *grPtr = NULL;
return (getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf),
&grPtr) == 0 && grPtr != NULL) ? &tsdPtr->grp : NULL;
#elif defined(HAVE_GETGRGID_R_4)
return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
struct group *grPtr;
Tcl_MutexLock(&compatLock);
grPtr = getgrgid(gid);
if (grPtr != NULL) {
tsdPtr->grp = *grPtr;
grPtr = &tsdPtr->grp;
if (CopyGrp(&tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf)) == -1) {
grPtr = NULL;
}
}
Tcl_MutexUnlock(&compatLock);
return grPtr;
#endif
return NULL; /* Not reached */
#endif /* TCL_THREADS */
}
/*
*---------------------------------------------------------------------------
*
* TclpGetHostByName --
*
* Thread-safe wrappers for gethostbyname().
* See "man gethostbyname" for more details.
*
* Results:
* Pointer to struct hostent on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct hostent *
TclpGetHostByName(const char *name)
{
#if !defined(TCL_THREADS) || defined(HAVE_MTSAFE_GETHOSTBYNAME)
return gethostbyname(name);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETHOSTBYNAME_R_5)
int h_errno;
return gethostbyname_r(name, &tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf), &h_errno);
#elif defined(HAVE_GETHOSTBYNAME_R_6)
struct hostent *hePtr;
int h_errno;
return (gethostbyname_r(name, &tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf), &hePtr, &h_errno) == 0) ?
&tsdPtr->hent : NULL;
#elif defined(HAVE_GETHOSTBYNAME_R_3)
struct hostent_data data;
return (gethostbyname_r(name, &tsdPtr->hent, &data) == 0) ?
&tsdPtr->hent : NULL;
#else
struct hostent *hePtr;
Tcl_MutexLock(&compatLock);
hePtr = gethostbyname(name);
if (hePtr != NULL) {
tsdPtr->hent = *hePtr;
hePtr = &tsdPtr->hent;
if (CopyHostent(&tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf)) == -1) {
hePtr = NULL;
}
}
Tcl_MutexUnlock(&compatLock);
return hePtr;
#endif
return NULL; /* Not reached */
#endif /* TCL_THREADS */
}
/*
*---------------------------------------------------------------------------
*
* TclpGetHostByAddr --
*
* Thread-safe wrappers for gethostbyaddr().
* See "man gethostbyaddr" for more details.
*
* Results:
* Pointer to struct hostent on success or NULL on error.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
struct hostent *
TclpGetHostByAddr(const char *addr, int length, int type)
{
#if !defined(TCL_THREADS) || defined(HAVE_MTSAFE_GETHOSTBYADDR)
return gethostbyaddr(addr, length, type);
#else
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if defined(HAVE_GETHOSTBYADDR_R_7)
int h_errno;
return gethostbyaddr_r(addr, length, type, &tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf), &h_errno);
#elif defined(HAVE_GETHOSTBYADDR_R_8)
struct hostent *hePtr;
int h_errno;
return (gethostbyaddr_r(addr, length, type, &tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf), &hePtr, &h_errno) == 0) ?
&tsdPtr->hent : NULL;
#else
struct hostent *hePtr;
Tcl_MutexLock(&compatLock);
hePtr = gethostbyaddr(addr, length, type);
if (hePtr != NULL) {
tsdPtr->hent = *hePtr;
hePtr = &tsdPtr->hent;
if (CopyHostent(&tsdPtr->hent, tsdPtr->hbuf,
sizeof(tsdPtr->hbuf)) == -1) {
hePtr = NULL;
}
}
Tcl_MutexUnlock(&compatLock);
return hePtr;
#endif
return NULL; /* Not reached */
#endif /* TCL_THREADS */
}
|
Changes to unix/tclUnixFCmd.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclUnixFCmd.c * * This file implements the unix specific portion of file manipulation * subcommands of the "file" command. All filename arguments should * already be translated to native format. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclUnixFCmd.c * * This file implements the unix specific portion of file manipulation * subcommands of the "file" command. All filename arguments should * already be translated to native format. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUnixFCmd.c,v 1.28.2.15 2007/04/29 02:19:51 das Exp $ * * Portions of this code were derived from NetBSD source code which has * the following copyright notice: * * Copyright (c) 1988, 1993, 1994 * The Regents of the University of California. All rights reserved. * |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 | #include <utime.h> #include <grp.h> #ifndef HAVE_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> #endif #endif /* * The following constants specify the type of callback when * TraverseUnixTree() calls the traverseProc() */ #define DOTREE_PRED 1 /* pre-order directory */ | > > > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | #include <utime.h> #include <grp.h> #ifndef HAVE_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> #endif #endif #ifdef HAVE_FTS #include <fts.h> #endif /* * The following constants specify the type of callback when * TraverseUnixTree() calls the traverseProc() */ #define DOTREE_PRED 1 /* pre-order directory */ |
| ︙ | ︙ | |||
119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
CONST TclFileAttrProcs tclpFileAttrProcs[] = {
{GetGroupAttribute, SetGroupAttribute},
{GetOwnerAttribute, SetOwnerAttribute},
{GetPermissionsAttribute, SetPermissionsAttribute}
};
/*
* Declarations for local procedures defined in this file:
*/
static int CopyFile _ANSI_ARGS_((CONST char *src,
CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
static int CopyFileAtts _ANSI_ARGS_((CONST char *src,
CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
static int DoCopyFile _ANSI_ARGS_((CONST char *srcPtr,
| > > > > > > > > > > > > > > > | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
CONST TclFileAttrProcs tclpFileAttrProcs[] = {
{GetGroupAttribute, SetGroupAttribute},
{GetOwnerAttribute, SetOwnerAttribute},
{GetPermissionsAttribute, SetPermissionsAttribute}
};
/*
* This is the maximum number of consecutive readdir/unlink calls that can be
* made (with no intervening rewinddir or closedir/opendir) before triggering
* a bug that makes readdir return NULL even though some directory entries
* have not been processed. The bug afflicts SunOS's readdir when applied to
* ufs file systems and Darwin 6.5's (and OSX v.10.3.8's) HFS+. JH found the
* Darwin readdir to reset at 147, so 130 is chosen to be conservative. We
* can't do a general rewind on failure as NFS can create special files that
* recreate themselves when you try and delete them. 8.4.8 added a solution
* that was affected by a single such NFS file, this solution should not be
* affected by less than THRESHOLD such files. [Bug 1034337]
*/
#define MAX_READDIR_UNLINK_THRESHOLD 130
/*
* Declarations for local procedures defined in this file:
*/
static int CopyFile _ANSI_ARGS_((CONST char *src,
CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
static int CopyFileAtts _ANSI_ARGS_((CONST char *src,
CONST char *dst, CONST Tcl_StatBuf *statBufPtr));
static int DoCopyFile _ANSI_ARGS_((CONST char *srcPtr,
CONST char *dstPtr, CONST Tcl_StatBuf *statBufPtr));
static int DoCreateDirectory _ANSI_ARGS_((CONST char *pathPtr));
static int DoRemoveDirectory _ANSI_ARGS_((Tcl_DString *pathPtr,
int recursive, Tcl_DString *errorPtr));
static int DoRenameFile _ANSI_ARGS_((CONST char *src,
CONST char *dst));
static int TraversalCopy _ANSI_ARGS_((Tcl_DString *srcPtr,
Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr,
int type, Tcl_DString *errorPtr));
static int TraversalDelete _ANSI_ARGS_((Tcl_DString *srcPtr,
Tcl_DString *dstPtr, CONST Tcl_StatBuf *statBufPtr,
int type, Tcl_DString *errorPtr));
static int TraverseUnixTree _ANSI_ARGS_((
TraversalProc *traversalProc,
Tcl_DString *sourcePtr, Tcl_DString *destPtr,
Tcl_DString *errorPtr, int doRewind));
#ifdef PURIFY
/*
* realpath and purify don't mix happily. It has been noted that realpath
* should not be used with purify because of bogus warnings, but just
* memset'ing the resolved path will squelch those. This assumes we are
* passing the standard MAXPATHLEN size resolved arg.
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
memset(resolved, 0, MAXPATHLEN);
return realpath(path, resolved);
}
#else
#define Realpath realpath
#endif
/*
*---------------------------------------------------------------------------
*
* TclpObjRenameFile, DoRenameFile --
*
* Changes the name of an existing file or directory, from src to dst.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
memset(resolved, 0, MAXPATHLEN);
return realpath(path, resolved);
}
#else
#define Realpath realpath
#endif
#ifndef NO_REALPATH
#if defined(__APPLE__) && defined(TCL_THREADS) && \
defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \
MAC_OS_X_VERSION_MIN_REQUIRED < 1030
/*
* prior to Darwin 7, realpath is not threadsafe, c.f. bug 711232;
* if we might potentially be running on pre-10.3 OSX,
* check Darwin release at runtime before using realpath.
*/
extern long tclMacOSXDarwinRelease;
#define haveRealpath (tclMacOSXDarwinRelease >= 7)
#else
#define haveRealpath 1
#endif
#endif /* NO_REALPATH */
#ifdef HAVE_FTS
#ifdef HAVE_STRUCT_STAT64
/* fts doesn't do stat64 */
#define noFtsStat 1
#elif defined(__APPLE__) && defined(__LP64__) && \
defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \
MAC_OS_X_VERSION_MIN_REQUIRED < 1050
/*
* prior to Darwin 9, 64bit fts_open() without FTS_NOSTAT may crash (due to a
* 64bit-unsafe ALIGN macro); if we could be running on pre-10.5 OSX, check
* Darwin release at runtime and do a separate stat() if necessary.
*/
extern long tclMacOSXDarwinRelease;
#define noFtsStat (tclMacOSXDarwinRelease < 9)
#else
#define noFtsStat 0
#endif
#endif /* HAVE_FTS */
/*
*---------------------------------------------------------------------------
*
* TclpObjRenameFile, DoRenameFile --
*
* Changes the name of an existing file or directory, from src to dst.
|
| ︙ | ︙ | |||
244 245 246 247 248 249 250 |
/*
* SunOS 4.1.4 reports overwriting a non-empty directory with a
* directory as EINVAL instead of EEXIST (first rule out the correct
* EINVAL result code for moving a directory into itself). Must be
* conditionally compiled because realpath() not defined on all systems.
*/
| | | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 |
/*
* SunOS 4.1.4 reports overwriting a non-empty directory with a
* directory as EINVAL instead of EEXIST (first rule out the correct
* EINVAL result code for moving a directory into itself). Must be
* conditionally compiled because realpath() not defined on all systems.
*/
if (errno == EINVAL && haveRealpath) {
char srcPath[MAXPATHLEN], dstPath[MAXPATHLEN];
DIR *dirPtr;
Tcl_DirEntry *dirEntPtr;
if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */
&& (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
&& (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
|
| ︙ | ︙ | |||
324 325 326 327 328 329 330 |
*/
int
TclpObjCopyFile(srcPathPtr, destPathPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
{
| | > > > > > > | | < | | < < < | | < | | | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 |
*/
int
TclpObjCopyFile(srcPathPtr, destPathPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
{
CONST char *src = Tcl_FSGetNativePath(srcPathPtr);
Tcl_StatBuf srcStatBuf;
if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */
return TCL_ERROR;
}
return DoCopyFile(src, Tcl_FSGetNativePath(destPathPtr), &srcStatBuf);
}
static int
DoCopyFile(src, dst, statBufPtr)
CONST char *src; /* Pathname of file to be copied (native). */
CONST char *dst; /* Pathname of file to copy to (native). */
CONST Tcl_StatBuf *statBufPtr;
/* Used to determine filetype. */
{
Tcl_StatBuf dstStatBuf;
if (S_ISDIR(statBufPtr->st_mode)) {
errno = EISDIR;
return TCL_ERROR;
}
/*
* symlink, and some of the other calls will fail if the target
* exists, so we remove it first
|
| ︙ | ︙ | |||
364 365 366 367 368 369 370 |
}
if (unlink(dst) != 0) { /* INTL: Native. */
if (errno != ENOENT) {
return TCL_ERROR;
}
}
| | > > > > > > | | | | | | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 |
}
if (unlink(dst) != 0) { /* INTL: Native. */
if (errno != ENOENT) {
return TCL_ERROR;
}
}
switch ((int) (statBufPtr->st_mode & S_IFMT)) {
#ifndef DJGPP
case S_IFLNK: {
char link[MAXPATHLEN];
int length;
length = readlink(src, link, sizeof(link)); /* INTL: Native. */
if (length == -1) {
return TCL_ERROR;
}
link[length] = '\0';
if (symlink(link, dst) < 0) { /* INTL: Native. */
return TCL_ERROR;
}
#ifdef HAVE_COPYFILE
#ifdef WEAK_IMPORT_COPYFILE
if (copyfile != NULL)
#endif
copyfile(src, dst, NULL, COPYFILE_XATTR|COPYFILE_NOFOLLOW_SRC);
#endif
break;
}
#endif
case S_IFBLK:
case S_IFCHR: {
if (mknod(dst, statBufPtr->st_mode, /* INTL: Native. */
statBufPtr->st_rdev) < 0) {
return TCL_ERROR;
}
return CopyFileAtts(src, dst, statBufPtr);
}
case S_IFIFO: {
if (mkfifo(dst, statBufPtr->st_mode) < 0) { /* INTL: Native. */
return TCL_ERROR;
}
return CopyFileAtts(src, dst, statBufPtr);
}
default: {
return CopyFile(src, dst, statBufPtr);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
CONST char *dst; /* Pathname of file to create/overwrite
* (native). */
CONST Tcl_StatBuf *statBufPtr;
/* Used to determine mode and blocksize. */
{
int srcFd;
int dstFd;
| | | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 |
CONST char *dst; /* Pathname of file to create/overwrite
* (native). */
CONST Tcl_StatBuf *statBufPtr;
/* Used to determine mode and blocksize. */
{
int srcFd;
int dstFd;
unsigned blockSize; /* Optimal I/O blocksize for filesystem */
char *buffer; /* Data buffer for copy */
size_t nread;
if ((srcFd = TclOSopen(src, O_RDONLY, 0)) < 0) { /* INTL: Native. */
return TCL_ERROR;
}
dstFd = TclOSopen(dst, O_CREAT|O_TRUNC|O_WRONLY, /* INTL: Native. */
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 |
}
}
#else
blockSize = 4096;
#endif
#endif
buffer = ckalloc(blockSize);
while (1) {
nread = read(srcFd, buffer, blockSize);
if ((nread == -1) || (nread == 0)) {
break;
}
if (write(dstFd, buffer, nread) != nread) {
nread = (size_t) -1;
break;
}
}
| > > > > > > > > > > | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 |
}
}
#else
blockSize = 4096;
#endif
#endif
/* [SF Tcl Bug 1586470] Even if we HAVE_ST_BLKSIZE, there are
* filesystems which report a bogus value for the blocksize. An
* example is the Andrew Filesystem (afs), reporting a blocksize
* of 0. When detecting such a situation we now simply fall back
* to a hardwired default size.
*/
if (blockSize <= 0) {
blockSize = 4096;
}
buffer = ckalloc(blockSize);
while (1) {
nread = read(srcFd, buffer, blockSize);
if ((nread == -1) || (nread == 0)) {
break;
}
if (write(dstFd, buffer, nread) != nread) {
nread = (size_t) -1;
break;
}
}
ckfree(buffer);
close(srcFd);
if ((close(dstFd) != 0) || (nread == -1)) {
unlink(dst); /* INTL: Native. */
return TCL_ERROR;
}
if (CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) {
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 |
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
Tcl_DString srcString, dstString;
int ret;
| > | > | > > > > | > > | > | | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
Tcl_DString srcString, dstString;
int ret;
Tcl_Obj *transPtr;
transPtr = Tcl_FSGetTranslatedPath(NULL,srcPathPtr);
Tcl_UtfToExternalDString(NULL,
(transPtr != NULL ? Tcl_GetString(transPtr) : NULL),
-1, &srcString);
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
transPtr = Tcl_FSGetTranslatedPath(NULL,destPathPtr);
Tcl_UtfToExternalDString(NULL,
(transPtr != NULL ? Tcl_GetString(transPtr) : NULL),
-1, &dstString);
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
ret = TraverseUnixTree(TraversalCopy, &srcString, &dstString, &ds, 0);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
677 678 679 680 681 682 683 684 |
Tcl_Obj *pathPtr;
int recursive;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
Tcl_DString pathString;
int ret;
| > | > > > > | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 |
Tcl_Obj *pathPtr;
int recursive;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
Tcl_DString pathString;
int ret;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
Tcl_UtfToExternalDString(NULL,
(transPtr != NULL ? Tcl_GetString(transPtr) : NULL),
-1, &pathString);
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
ret = DoRemoveDirectory(&pathString, recursive, &ds);
Tcl_DStringFree(&pathString);
if (ret != TCL_OK) {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 |
/*
* The directory is nonempty, but the recursive flag has been
* specified, so we recursively remove all the files in the directory.
*/
if (result == TCL_OK) {
| | | | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 |
/*
* The directory is nonempty, but the recursive flag has been
* specified, so we recursively remove all the files in the directory.
*/
if (result == TCL_OK) {
result = TraverseUnixTree(TraversalDelete, pathPtr, NULL, errorPtr, 1);
}
if ((result != TCL_OK) && (recursive != 0)) {
/* Try to restore permissions */
chmod(path, oldPerm);
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* TraverseUnixTree --
*
* Traverse directory tree specified by sourcePtr, calling the function
* traverseProc for each file and directory encountered. If destPtr
|
| ︙ | ︙ | |||
775 776 777 778 779 780 781 | * traverseProc() may change state. If an error occurs, the error will * be returned immediately, and remaining files will not be processed. * *--------------------------------------------------------------------------- */ static int | | > > > > > > > > > > > > > > | | | | > > | > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 |
* traverseProc() may change state. If an error occurs, the error will
* be returned immediately, and remaining files will not be processed.
*
*---------------------------------------------------------------------------
*/
static int
TraverseUnixTree(traverseProc, sourcePtr, targetPtr, errorPtr, doRewind)
TraversalProc *traverseProc;/* Function to call for every file and
* directory in source hierarchy. */
Tcl_DString *sourcePtr; /* Pathname of source directory to be
* traversed (native). */
Tcl_DString *targetPtr; /* Pathname of directory to traverse in
* parallel with source directory (native). */
Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
int doRewind; /* Flag indicating that to ensure complete
* traversal of source hierarchy, the readdir
* loop should be rewound whenever
* traverseProc has returned TCL_OK; this is
* required when traverseProc modifies the
* source hierarchy, e.g. by deleting files. */
{
Tcl_StatBuf statBuf;
CONST char *source, *errfile;
int result, sourceLen;
int targetLen;
#ifndef HAVE_FTS
int numProcessed = 0;
Tcl_DirEntry *dirEntPtr;
DIR *dirPtr;
#else
CONST char *paths[2] = {NULL, NULL};
FTS *fts = NULL;
FTSENT *ent;
#endif
errfile = NULL;
result = TCL_OK;
targetLen = 0; /* lint. */
source = Tcl_DStringValue(sourcePtr);
if (TclOSlstat(source, &statBuf) != 0) { /* INTL: Native. */
errfile = source;
goto end;
}
if (!S_ISDIR(statBuf.st_mode)) {
/*
* Process the regular file
*/
return (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_F,
errorPtr);
}
#ifndef HAVE_FTS
dirPtr = opendir(source); /* INTL: Native. */
if (dirPtr == NULL) {
/*
* Can't read directory
*/
errfile = source;
goto end;
}
result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_PRED,
errorPtr);
if (result != TCL_OK) {
closedir(dirPtr);
return result;
}
Tcl_DStringAppend(sourcePtr, "/", 1);
sourceLen = Tcl_DStringLength(sourcePtr);
if (targetPtr != NULL) {
Tcl_DStringAppend(targetPtr, "/", 1);
targetLen = Tcl_DStringLength(targetPtr);
}
while ((dirEntPtr = TclOSreaddir(dirPtr)) != NULL) { /* INTL: Native. */
if ((dirEntPtr->d_name[0] == '.')
&& ((dirEntPtr->d_name[1] == '\0')
|| (strcmp(dirEntPtr->d_name, "..") == 0))) {
continue;
}
/*
* Append name after slash, and recurse on the file.
*/
Tcl_DStringAppend(sourcePtr, dirEntPtr->d_name, -1);
if (targetPtr != NULL) {
Tcl_DStringAppend(targetPtr, dirEntPtr->d_name, -1);
}
result = TraverseUnixTree(traverseProc, sourcePtr, targetPtr,
errorPtr, doRewind);
if (result != TCL_OK) {
break;
} else {
numProcessed++;
}
/*
* Remove name after slash.
*/
Tcl_DStringSetLength(sourcePtr, sourceLen);
if (targetPtr != NULL) {
Tcl_DStringSetLength(targetPtr, targetLen);
}
if (doRewind && (numProcessed > MAX_READDIR_UNLINK_THRESHOLD)) {
/*
* Call rewinddir if we've called unlink or rmdir so many times
* (since the opendir or the previous rewinddir), to avoid
* a NULL-return that may a symptom of a buggy readdir.
*/
rewinddir(dirPtr);
numProcessed = 0;
}
}
closedir(dirPtr);
/*
* Strip off the trailing slash we added
*/
Tcl_DStringSetLength(sourcePtr, sourceLen - 1);
if (targetPtr != NULL) {
Tcl_DStringSetLength(targetPtr, targetLen - 1);
}
if (result == TCL_OK) {
/*
* Call traverseProc() on a directory after visiting all the
* files in that directory.
*/
result = (*traverseProc)(sourcePtr, targetPtr, &statBuf, DOTREE_POSTD,
errorPtr);
}
#else /* HAVE_FTS */
paths[0] = source;
fts = fts_open((char**)paths, FTS_PHYSICAL | FTS_NOCHDIR |
(noFtsStat || doRewind ? FTS_NOSTAT : 0), NULL);
if (fts == NULL) {
errfile = source;
goto end;
}
sourceLen = Tcl_DStringLength(sourcePtr);
if (targetPtr != NULL) {
targetLen = Tcl_DStringLength(targetPtr);
}
while ((ent = fts_read(fts)) != NULL) {
unsigned short info = ent->fts_info;
char * path = ent->fts_path + sourceLen;
unsigned short pathlen = ent->fts_pathlen - sourceLen;
int type;
Tcl_StatBuf *statBufPtr = NULL;
if (info == FTS_DNR || info == FTS_ERR || info == FTS_NS) {
errfile = ent->fts_path;
break;
}
Tcl_DStringAppend(sourcePtr, path, pathlen);
if (targetPtr != NULL) {
Tcl_DStringAppend(targetPtr, path, pathlen);
}
switch (info) {
case FTS_D:
type = DOTREE_PRED;
break;
case FTS_DP:
type = DOTREE_POSTD;
break;
default:
type = DOTREE_F;
break;
}
if (!doRewind) { /* no need to stat for delete */
if (noFtsStat) {
statBufPtr = &statBuf;
if (TclOSlstat(ent->fts_path, statBufPtr) != 0) {
errfile = ent->fts_path;
break;
}
} else {
statBufPtr = ent->fts_statp;
}
}
result = (*traverseProc)(sourcePtr, targetPtr, statBufPtr, type,
errorPtr);
if (result != TCL_OK) {
break;
}
Tcl_DStringSetLength(sourcePtr, sourceLen);
if (targetPtr != NULL) {
Tcl_DStringSetLength(targetPtr, targetLen);
}
}
#endif /* HAVE_FTS */
end:
if (errfile != NULL) {
if (errorPtr != NULL) {
Tcl_ExternalToUtfDString(NULL, errfile, -1, errorPtr);
}
result = TCL_ERROR;
}
#ifdef HAVE_FTS
if (fts != NULL) {
fts_close(fts);
}
#endif /* HAVE_FTS */
return result;
}
/*
*----------------------------------------------------------------------
*
* TraversalCopy
|
| ︙ | ︙ | |||
926 927 928 929 930 931 932 |
int type; /* Reason for call - see TraverseUnixTree(). */
Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
{
switch (type) {
case DOTREE_F:
| | | | 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 |
int type; /* Reason for call - see TraverseUnixTree(). */
Tcl_DString *errorPtr; /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
{
switch (type) {
case DOTREE_F:
if (DoCopyFile(Tcl_DStringValue(srcPtr), Tcl_DStringValue(dstPtr),
statBufPtr) == TCL_OK) {
return TCL_OK;
}
break;
case DOTREE_PRED:
if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) {
return TCL_OK;
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 |
tval.actime = statBufPtr->st_atime;
tval.modtime = statBufPtr->st_mtime;
if (utime(dst, &tval)) { /* INTL: Native. */
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| > > > > > > | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 |
tval.actime = statBufPtr->st_atime;
tval.modtime = statBufPtr->st_mtime;
if (utime(dst, &tval)) { /* INTL: Native. */
return TCL_ERROR;
}
#ifdef HAVE_COPYFILE
#ifdef WEAK_IMPORT_COPYFILE
if (copyfile != NULL)
#endif
copyfile(src, dst, NULL, COPYFILE_XATTR|COPYFILE_ACL);
#endif
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1108 1109 1110 1111 1112 1113 1114 |
if (result != 0) {
Tcl_AppendResult(interp, "could not read \"",
Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
| | > | | 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 |
if (result != 0) {
Tcl_AppendResult(interp, "could not read \"",
Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
groupPtr = TclpGetGrGid(statBuf.st_gid);
if (result == -1 || groupPtr == NULL) {
*attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_gid);
} else {
Tcl_DString ds;
CONST char *utf;
utf = Tcl_ExternalToUtfDString(NULL, groupPtr->gr_name, -1, &ds);
*attributePtrPtr = Tcl_NewStringObj(utf, -1);
|
| ︙ | ︙ | |||
1160 1161 1162 1163 1164 1165 1166 |
if (result != 0) {
Tcl_AppendResult(interp, "could not read \"",
Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
| | > | | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 |
if (result != 0) {
Tcl_AppendResult(interp, "could not read \"",
Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
pwPtr = TclpGetPwUid(statBuf.st_uid);
if (result == -1 || pwPtr == NULL) {
*attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid);
} else {
Tcl_DString ds;
CONST char *utf;
utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds);
*attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds));
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 |
if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
Tcl_DString ds;
struct group *groupPtr;
CONST char *string;
int length;
string = Tcl_GetStringFromObj(attributePtr, &length);
| < | | 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 |
if (Tcl_GetLongFromObj(NULL, attributePtr, &gid) != TCL_OK) {
Tcl_DString ds;
struct group *groupPtr;
CONST char *string;
int length;
string = Tcl_GetStringFromObj(attributePtr, &length);
native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
groupPtr = TclpGetGrNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (groupPtr == NULL) {
endgrent();
Tcl_AppendResult(interp, "could not set group for file \"",
Tcl_GetString(fileName), "\": group \"",
string, "\" does not exist",
|
| ︙ | ︙ | |||
1316 1317 1318 1319 1320 1321 1322 |
if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
Tcl_DString ds;
struct passwd *pwPtr;
CONST char *string;
int length;
string = Tcl_GetStringFromObj(attributePtr, &length);
| < | > | > | 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 |
if (Tcl_GetLongFromObj(NULL, attributePtr, &uid) != TCL_OK) {
Tcl_DString ds;
struct passwd *pwPtr;
CONST char *string;
int length;
string = Tcl_GetStringFromObj(attributePtr, &length);
native = Tcl_UtfToExternalDString(NULL, string, length, &ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
endpwent();
Tcl_AppendResult(interp, "could not set owner for file \"",
Tcl_GetString(fileName), "\": user \"",
string, "\" does not exist",
(char *) NULL);
return TCL_ERROR;
}
uid = pwPtr->pw_uid;
}
native = Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */
endpwent();
if (result != 0) {
Tcl_AppendResult(interp, "could not set owner for file \"",
Tcl_GetString(fileName), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
|
| ︙ | ︙ | |||
1583 1584 1585 1586 1587 1588 1589 | continue; case '=' : op = 3; op_found = 1; continue; default : return TCL_ERROR; | < | 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 |
continue;
case '=' :
op = 3;
op_found = 1;
continue;
default :
return TCL_ERROR;
}
}
/* what */
switch (*(modeStringPtr+n+i)) {
case 'r' :
what |= 0x124;
continue;
|
| ︙ | ︙ | |||
1607 1608 1609 1610 1611 1612 1613 | case 't' : what |= 0x200; continue; case ',' : break; default : return TCL_ERROR; | < | 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 |
case 't' :
what |= 0x200;
continue;
case ',' :
break;
default :
return TCL_ERROR;
}
if (*(modeStringPtr+n+i) == ',') {
i++;
break;
}
}
switch (op) {
|
| ︙ | ︙ | |||
1676 1677 1678 1679 1680 1681 1682 |
currentPathEndPosition = path + nextCheckpoint;
if (*currentPathEndPosition == '/') {
currentPathEndPosition++;
}
#ifndef NO_REALPATH
/* For speed, try to get the entire path in one go */
| | > > > > > > | | | > > | 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 |
currentPathEndPosition = path + nextCheckpoint;
if (*currentPathEndPosition == '/') {
currentPathEndPosition++;
}
#ifndef NO_REALPATH
/* For speed, try to get the entire path in one go */
if (nextCheckpoint == 0 && haveRealpath) {
char *lastDir = strrchr(currentPathEndPosition, '/');
if (lastDir != NULL) {
nativePath = Tcl_UtfToExternalDString(NULL, path,
lastDir - path, &ds);
if (Realpath(nativePath, normPath) != NULL) {
if (*nativePath != '/' && *normPath == '/') {
/*
* realpath has transformed a relative path into an
* absolute path, we do not know how to handle this.
*/
} else {
nextCheckpoint = lastDir - path;
goto wholeStringOk;
}
}
Tcl_DStringFree(&ds);
}
}
/* Else do it the slow way */
#endif
while (1) {
cur = *currentPathEndPosition;
|
| ︙ | ︙ | |||
1722 1723 1724 1725 1726 1727 1728 |
* We should really now convert this to a canonical path. We do
* that with 'realpath' if we have it available. Otherwise we could
* step through every single path component, checking whether it is a
* symlink, but that would be a lot of work, and most modern OSes
* have 'realpath'.
*/
#ifndef NO_REALPATH
| > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > < < < | 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 |
* We should really now convert this to a canonical path. We do
* that with 'realpath' if we have it available. Otherwise we could
* step through every single path component, checking whether it is a
* symlink, but that would be a lot of work, and most modern OSes
* have 'realpath'.
*/
#ifndef NO_REALPATH
if (haveRealpath) {
/*
* If we only had '/foo' or '/' then we never increment nextCheckpoint
* and we don't need or want to go through 'Realpath'. Also, on some
* platforms, passing an empty string to 'Realpath' will give us the
* normalized pwd, which is not what we want at all!
*/
if (nextCheckpoint == 0) return 0;
nativePath = Tcl_UtfToExternalDString(NULL, path, nextCheckpoint, &ds);
if (Realpath(nativePath, normPath) != NULL) {
int newNormLen;
wholeStringOk:
newNormLen = strlen(normPath);
if ((newNormLen == Tcl_DStringLength(&ds))
&& (strcmp(normPath, nativePath) == 0)) {
/* String is unchanged */
Tcl_DStringFree(&ds);
if (path[nextCheckpoint] != '\0') {
nextCheckpoint++;
}
return nextCheckpoint;
}
/*
* Free up the native path and put in its place the
* converted, normalized path.
*/
Tcl_DStringFree(&ds);
Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds);
if (path[nextCheckpoint] != '\0') {
/* not at end, append remaining path */
int normLen = Tcl_DStringLength(&ds);
Tcl_DStringAppend(&ds, path + nextCheckpoint,
pathLen - nextCheckpoint);
/*
* We recognise up to and including the directory
* separator.
*/
nextCheckpoint = normLen + 1;
} else {
/* We recognise the whole string */
nextCheckpoint = Tcl_DStringLength(&ds);
}
/*
* Overwrite with the normalized path.
*/
Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
}
Tcl_DStringFree(&ds);
}
#endif /* !NO_REALPATH */
return nextCheckpoint;
}
|
Changes to unix/tclUnixFile.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclUnixFile.c -- * * This file contains wrappers around UNIX file handling functions. * These wrappers mask differences between Windows and UNIX. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclUnixFile.c -- * * This file contains wrappers around UNIX file handling functions. * These wrappers mask differences between Windows and UNIX. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUnixFile.c,v 1.32.2.2 2003/10/31 08:46:41 vincentdarley Exp $ */ #include "tclInt.h" #include "tclPort.h" static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types); |
| ︙ | ︙ | |||
217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
if (pattern == NULL || (*pattern == '\0')) {
/* Match a file directly */
native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
if (NativeMatchType(native, types)) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
return TCL_OK;
} else {
DIR *d;
Tcl_DirEntry *entryPtr;
CONST char *dirName;
int dirLength;
int matchHidden;
| > | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
if (pattern == NULL || (*pattern == '\0')) {
/* Match a file directly */
native = (CONST char*) Tcl_FSGetNativePath(pathPtr);
if (NativeMatchType(native, types)) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(fileNamePtr);
return TCL_OK;
} else {
DIR *d;
Tcl_DirEntry *entryPtr;
CONST char *dirName;
int dirLength;
int matchHidden;
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
dirName = Tcl_DStringValue(&dsOrig);
/* Make sure we have a trailing directory delimiter */
if (dirName[dirLength-1] != '/') {
dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
dirLength++;
}
}
| > | | 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
dirName = Tcl_DStringValue(&dsOrig);
/* Make sure we have a trailing directory delimiter */
if (dirName[dirLength-1] != '/') {
dirName = Tcl_DStringAppend(&dsOrig, "/", 1);
dirLength++;
}
}
Tcl_DecrRefCount(fileNamePtr);
/*
* Now open the directory for reading and iterate over the contents.
*/
native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds);
if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */
|
| ︙ | ︙ | |||
741 742 743 744 745 746 747 |
return toPtr;
} else {
Tcl_Obj* linkPtr = NULL;
char link[MAXPATHLEN];
int length;
Tcl_DString ds;
| > | | > > > | 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
return toPtr;
} else {
Tcl_Obj* linkPtr = NULL;
char link[MAXPATHLEN];
int length;
Tcl_DString ds;
Tcl_Obj *transPtr;
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, &ds);
linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
1 2 3 4 5 6 7 8 9 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * | | | | > > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. * * RCS: @(#) $Id: tclUnixInit.c,v 1.34.2.15 2007/04/29 02:19:51 das Exp $ */ #if defined(HAVE_COREFOUNDATION) #include <CoreFoundation/CoreFoundation.h> #endif #include "tclInt.h" #include "tclPort.h" #include <locale.h> #ifdef HAVE_LANGINFO # include <langinfo.h> # ifdef __APPLE__ # if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1030 /* Support for weakly importing nl_langinfo on Darwin. */ # define WEAK_IMPORT_NL_LANGINFO extern char *nl_langinfo(nl_item) WEAK_IMPORT_ATTRIBUTE; # endif # endif #endif #if defined(__FreeBSD__) && defined(__GNUC__) # include <floatingpoint.h> #endif #if defined(__bsdi__) # include <sys/param.h> # if _BSDI_VERSION > 199501 # include <dlfcn.h> # endif |
| ︙ | ︙ | |||
77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
CONST char *lang;
CONST char *encoding;
} LocaleTable;
static CONST LocaleTable localeTable[] = {
#ifdef HAVE_LANGINFO
{"gb2312-1980", "gb2312"},
#ifdef __hpux
{"SJIS", "shiftjis"},
{"eucjp", "euc-jp"},
{"euckr", "euc-kr"},
{"euctw", "euc-cn"},
{"greek8", "cp869"},
{"iso88591", "iso8859-1"},
| > | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
CONST char *lang;
CONST char *encoding;
} LocaleTable;
static CONST LocaleTable localeTable[] = {
#ifdef HAVE_LANGINFO
{"gb2312-1980", "gb2312"},
{"ansi-1251", "cp1251"}, /* Solaris gets this wrong. */
#ifdef __hpux
{"SJIS", "shiftjis"},
{"eucjp", "euc-jp"},
{"euckr", "euc-kr"},
{"euctw", "euc-cn"},
{"greek8", "cp869"},
{"iso88591", "iso8859-1"},
|
| ︙ | ︙ | |||
132 133 134 135 136 137 138 139 140 141 142 |
{"korean", "euc-kr"},
{"ru", "iso8859-5"},
{"ru_RU", "iso8859-5"},
{"ru_SU", "iso8859-5"},
{"zh", "cp936"},
{NULL, NULL}
};
| > > > > > | > | > | > > > > > > > > > > > > | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
{"korean", "euc-kr"},
{"ru", "iso8859-5"},
{"ru_RU", "iso8859-5"},
{"ru_SU", "iso8859-5"},
{"zh", "cp936"},
{"zh_CN.gb2312", "euc-cn"},
{"zh_CN.GB2312", "euc-cn"},
{"zh_CN.GBK", "euc-cn"},
{"zh_TW.Big5", "big5"},
{"zh_TW", "euc-tw"},
{NULL, NULL}
};
#ifdef HAVE_COREFOUNDATION
static int MacOSXGetLibraryPath _ANSI_ARGS_((
Tcl_Interp *interp, int maxPathLen,
char *tclLibPath));
#endif /* HAVE_COREFOUNDATION */
#if defined(__APPLE__) && (defined(TCL_LOAD_FROM_MEMORY) || ( \
defined(TCL_THREADS) && defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \
MAC_OS_X_VERSION_MIN_REQUIRED < 1030) || ( \
defined(__LP64__) && defined(MAC_OS_X_VERSION_MIN_REQUIRED) && \
MAC_OS_X_VERSION_MIN_REQUIRED < 1050))
/*
* Need to check Darwin release at runtime in tclUnixFCmd.c and tclLoadDyld.c:
* initialize release global at startup from uname().
*/
#define GET_DARWIN_RELEASE 1
long tclMacOSXDarwinRelease = 0;
#endif
/*
*---------------------------------------------------------------------------
*
* TclpInitPlatform --
*
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
*---------------------------------------------------------------------------
*/
void
TclpInitPlatform()
{
tclPlatform = TCL_PLATFORM_UNIX;
/*
* The code below causes SIGPIPE (broken pipe) errors to
* be ignored. This is needed so that Tcl processes don't
* die if they create child processes (e.g. using "exec" or
* "open") that terminate prematurely. The signal handler
* is only set up when the first interpreter is created;
* after this the application can override the handler with
* a different one of its own, if it wants.
*/
#ifdef SIGPIPE
(void) signal(SIGPIPE, SIG_IGN);
#endif /* SIGPIPE */
| > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 |
*---------------------------------------------------------------------------
*/
void
TclpInitPlatform()
{
tclPlatform = TCL_PLATFORM_UNIX;
/*
* Make sure, that the standard FDs exist. [Bug 772288]
*/
if (TclOSseek(0, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) {
open("/dev/null", O_RDONLY);
}
if (TclOSseek(1, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) {
open("/dev/null", O_WRONLY);
}
if (TclOSseek(2, (Tcl_SeekOffset) 0, SEEK_CUR) == -1 && errno == EBADF) {
open("/dev/null", O_WRONLY);
}
/*
* The code below causes SIGPIPE (broken pipe) errors to
* be ignored. This is needed so that Tcl processes don't
* die if they create child processes (e.g. using "exec" or
* "open") that terminate prematurely. The signal handler
* is only set up when the first interpreter is created;
* after this the application can override the handler with
* a different one of its own, if it wants.
*/
#ifdef SIGPIPE
(void) signal(SIGPIPE, SIG_IGN);
#endif /* SIGPIPE */
#if defined(__FreeBSD__) && defined(__GNUC__)
/*
* Adjust the rounding mode to be more conventional. Note that FreeBSD
* only provides the __fpsetreg() used by the following two for the GNU
* Compiler. When using, say, Intel's icc they break. (Partially based on
* patch in BSD ports system from root@celsius.bychok.com)
*/
fpsetround(FP_RN);
fpsetmask(0L);
#endif
#if defined(__bsdi__) && (_BSDI_VERSION > 199501)
/*
* Find local symbols. Don't report an error if we fail.
*/
(void) dlopen (NULL, RTLD_NOW); /* INTL: Native. */
#endif
#ifdef GET_DARWIN_RELEASE
{
struct utsname name;
if (!uname(&name)) {
tclMacOSXDarwinRelease = strtol(name.release, NULL, 10);
}
}
#endif
}
/*
*---------------------------------------------------------------------------
*
* TclpInitLibraryPath --
*
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 | * encoding. TclpSetInitialEncodings() will translate the library * path from the native encoding to UTF-8 as soon as it determines * what the native encoding actually is. * * Called at process initialization time. * * Results: | > | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
* encoding. TclpSetInitialEncodings() will translate the library
* path from the native encoding to UTF-8 as soon as it determines
* what the native encoding actually is.
*
* Called at process initialization time.
*
* Results:
* Return 1, indicating that the UTF may be dirty and require "cleanup"
* after encodings are initialized.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
TclpInitLibraryPath(path)
CONST char *path; /* Path to the executable in native
* multi-byte encoding. */
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
CONST char *str;
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 |
/*
* The variable path holds an absolute path. Take care not to
* overwrite pathv[0] since that might produce a relative path.
*/
if (path != NULL) {
| > > > | > > > > > > > > > > > > > > > | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
/*
* The variable path holds an absolute path. Take care not to
* overwrite pathv[0] since that might produce a relative path.
*/
if (path != NULL) {
int i, origc;
CONST char **origv;
Tcl_SplitPath(path, &origc, &origv);
pathc = 0;
pathv = (CONST char **) ckalloc((unsigned int)(origc * sizeof(char *)));
for (i=0; i< origc; i++) {
if (origv[i][0] == '.') {
if (strcmp(origv[i], ".") == 0) {
/* do nothing */
} else if (strcmp(origv[i], "..") == 0) {
pathc--;
} else {
pathv[pathc++] = origv[i];
}
} else {
pathv[pathc++] = origv[i];
}
}
if (pathc > 2) {
str = pathv[pathc - 2];
pathv[pathc - 2] = installLib;
path = Tcl_JoinPath(pathc - 1, pathv, &ds);
pathv[pathc - 2] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
pathv[pathc - 4] = developLib;
path = Tcl_JoinPath(pathc - 3, pathv, &ds);
pathv[pathc - 4] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
ckfree((char *) pathv);
}
/*
* Finally, look for the library relative to the compiled-in path.
* This is needed when users install Tcl with an exec-prefix that
* is different from the prtefix.
*/
| > | | | | | > > | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
pathv[pathc - 4] = developLib;
path = Tcl_JoinPath(pathc - 3, pathv, &ds);
pathv[pathc - 4] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
ckfree((char *) origv);
ckfree((char *) pathv);
}
/*
* Finally, look for the library relative to the compiled-in path.
* This is needed when users install Tcl with an exec-prefix that
* is different from the prtefix.
*/
{
#ifdef HAVE_COREFOUNDATION
char tclLibPath[MAXPATHLEN + 1];
if (MacOSXGetLibraryPath(NULL, MAXPATHLEN, tclLibPath) == TCL_OK) {
str = tclLibPath;
} else
#endif /* HAVE_COREFOUNDATION */
{
str = defaultLibraryDir;
}
if (str[0] != '\0') {
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
TclSetLibraryPath(pathPtr);
Tcl_DStringFree(&buffer);
return 1; /* 1 indicates that pathPtr may be dirty utf (needs cleaning) */
}
/*
*---------------------------------------------------------------------------
*
* TclpSetInitialEncodings --
*
|
| ︙ | ︙ | |||
446 447 448 449 450 451 452 |
*
*---------------------------------------------------------------------------
*/
void
TclpSetInitialEncodings()
{
| < > > > > | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 |
*
*---------------------------------------------------------------------------
*/
void
TclpSetInitialEncodings()
{
CONST char *encoding = NULL;
int i, setSysEncCode = TCL_ERROR;
Tcl_Obj *pathPtr;
/*
* Determine the current encoding from the LC_* or LANG environment
* variables. We previously used setlocale() to determine the locale,
* but this does not work on some systems (e.g. Linux/i386 RH 5.0).
*/
#ifdef HAVE_LANGINFO
if (
#ifdef WEAK_IMPORT_NL_LANGINFO
nl_langinfo != NULL &&
#endif
setlocale(LC_CTYPE, "") != NULL) {
Tcl_DString ds;
/*
* Use a DString so we can overwrite it in name compatability
* checks below.
*/
|
| ︙ | ︙ | |||
610 611 612 613 614 615 616 617 618 619 620 621 622 623 | * processing is done in "C" locale regardless. This is needed because * Tcl relies on routines like strtod, but should not have locale * dependent behavior. */ setlocale(LC_NUMERIC, "C"); /* * Until the system encoding was actually set, the library path was * actually in the native multi-byte encoding, and not really UTF-8 * as advertised. We cheated as follows: * * 1. It was safe to allow the Tcl_SetSystemEncoding() call to * append the ASCII chars that make up the encoding's filename to | > > | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 |
* processing is done in "C" locale regardless. This is needed because
* Tcl relies on routines like strtod, but should not have locale
* dependent behavior.
*/
setlocale(LC_NUMERIC, "C");
if ((libraryPathEncodingFixed == 0) && strcmp("identity",
Tcl_GetEncodingName(Tcl_GetEncoding(NULL, NULL))) ) {
/*
* Until the system encoding was actually set, the library path was
* actually in the native multi-byte encoding, and not really UTF-8
* as advertised. We cheated as follows:
*
* 1. It was safe to allow the Tcl_SetSystemEncoding() call to
* append the ASCII chars that make up the encoding's filename to
|
| ︙ | ︙ | |||
695 696 697 698 699 700 701 |
#ifndef NO_UNAME
struct utsname name;
#endif
int unameOK;
CONST char *user;
Tcl_DString ds;
| | | > > > > > > > > > > > > > > > > > > > > > > > > | | 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 |
#ifndef NO_UNAME
struct utsname name;
#endif
int unameOK;
CONST char *user;
Tcl_DString ds;
#ifdef HAVE_COREFOUNDATION
char tclLibPath[MAXPATHLEN + 1];
#if MAC_OS_X_VERSION_MAX_ALLOWED > 1020
/*
* Set msgcat fallback locale to current CFLocale identifier.
*/
CFLocaleRef localeRef;
if (CFLocaleCopyCurrent != NULL && CFLocaleGetIdentifier != NULL &&
(localeRef = CFLocaleCopyCurrent())) {
CFStringRef locale = CFLocaleGetIdentifier(localeRef);
if (locale) {
char loc[256];
if (CFStringGetCString(locale, loc, 256, kCFStringEncodingUTF8)) {
if (!Tcl_CreateNamespace(interp, "::tcl::mac", NULL, NULL)) {
Tcl_ResetResult(interp);
}
Tcl_SetVar(interp, "::tcl::mac::locale", loc, TCL_GLOBAL_ONLY);
}
}
CFRelease(localeRef);
}
#endif
if (MacOSXGetLibraryPath(interp, MAXPATHLEN, tclLibPath) == TCL_OK) {
CONST char *str;
Tcl_DString ds;
CFBundleRef bundleRef;
Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath,
TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 |
Tcl_DStringFree(&ds);
}
if ((bundleRef = CFBundleGetMainBundle())) {
CFURLRef frameworksURL;
Tcl_StatBuf statBuf;
if((frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef))) {
if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
| | | | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
Tcl_DStringFree(&ds);
}
if ((bundleRef = CFBundleGetMainBundle())) {
CFURLRef frameworksURL;
Tcl_StatBuf statBuf;
if((frameworksURL = CFBundleCopyPrivateFrameworksURL(bundleRef))) {
if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
}
if((frameworksURL = CFBundleCopySharedFrameworksURL(bundleRef))) {
if(CFURLGetFileSystemRepresentation(frameworksURL, TRUE,
(unsigned char*) tclLibPath, MAXPATHLEN) &&
! TclOSstat(tclLibPath, &statBuf) &&
S_ISDIR(statBuf.st_mode)) {
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
Tcl_SetVar(interp, "tcl_pkgPath", " ",
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
}
CFRelease(frameworksURL);
}
}
Tcl_SetVar(interp, "tcl_pkgPath", pkgPath,
TCL_GLOBAL_ONLY | TCL_APPEND_VALUE);
} else
#endif /* HAVE_COREFOUNDATION */
{
Tcl_SetVar(interp, "tclDefaultLibrary", defaultLibraryDir,
TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
}
#ifdef DJGPP
|
| ︙ | ︙ | |||
916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 |
};
}
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
pathPtr = Tcl_NewObj();
}
Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
return Tcl_Eval(interp, initScript);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceRCFile --
| > > | 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 |
};
}
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
pathPtr = Tcl_NewObj();
}
Tcl_IncrRefCount(pathPtr);
Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(pathPtr);
return Tcl_Eval(interp, initScript);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceRCFile --
|
| ︙ | ︙ | |||
1009 1010 1011 1012 1013 1014 1015 |
/*
* This function is unimplemented on Unix platforms.
*/
return 1;
}
| < | | > > > | | | | < > | < | 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 |
/*
* This function is unimplemented on Unix platforms.
*/
return 1;
}
/*
*----------------------------------------------------------------------
*
* MacOSXGetLibraryPath --
*
* If we have a bundle structure for the Tcl installation,
* then check there first to see if we can find the libraries
* there.
*
* Results:
* TCL_OK if we have found the tcl library; TCL_ERROR otherwise.
*
* Side effects:
* Same as for Tcl_MacOSXOpenVersionedBundleResources.
*
*----------------------------------------------------------------------
*/
#ifdef HAVE_COREFOUNDATION
static int
MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath)
{
int foundInFramework = TCL_ERROR;
#ifdef TCL_FRAMEWORK
foundInFramework = Tcl_MacOSXOpenVersionedBundleResources(interp,
"com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen, tclLibPath);
#endif
return foundInFramework;
}
#endif /* HAVE_COREFOUNDATION */
|
Changes to unix/tclUnixNotfy.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclUnixNotify.c -- * * This file contains the implementation of the select-based * Unix-specific notifier, which is the lowest-level part of the * Tcl event loop. This file works together with * ../generic/tclNotify.c. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
/*
* tclUnixNotify.c --
*
* This file contains the implementation of the select-based
* Unix-specific notifier, which is the lowest-level part of the
* Tcl event loop. This file works together with
* ../generic/tclNotify.c.
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclUnixNotfy.c,v 1.11.2.16 2006/08/22 17:45:02 andreas_kupries Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier
* is in tclMacOSXNotify.c */
#include <signal.h>
extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;
/*
* This structure is used to keep track of the notifier info for a
* a registered file.
*/
typedef struct FileHandler {
|
| ︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
int fd; /* File descriptor that is ready. Used
* to find the FileHandler structure for
* the file (can't point directly to the
* FileHandler structure because it could
* go away while the event is queued). */
} FileHandlerEvent;
/*
* The following static structure contains the state information for the
* select based implementation of the Tcl notifier. One of these structures
* is created for each thread that is using the notifier.
*/
typedef struct ThreadSpecificData {
FileHandler *firstFileHandlerPtr;
/* Pointer to head of file handler list. */
| > > > > > > > > > > > > | | < | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
int fd; /* File descriptor that is ready. Used
* to find the FileHandler structure for
* the file (can't point directly to the
* FileHandler structure because it could
* go away while the event is queued). */
} FileHandlerEvent;
/*
*
* The following structure contains a set of select() masks to track
* readable, writable, and exceptional conditions.
*/
typedef struct SelectMasks {
fd_set readable;
fd_set writable;
fd_set exceptional;
} SelectMasks;
/*
* The following static structure contains the state information for the
* select based implementation of the Tcl notifier. One of these structures
* is created for each thread that is using the notifier.
*/
typedef struct ThreadSpecificData {
FileHandler *firstFileHandlerPtr;
/* Pointer to head of file handler list. */
SelectMasks checkMasks; /* This structure is used to build up the masks
* to be used in the next call to select.
* Bits are set in response to calls to
* Tcl_CreateFileHandler. */
SelectMasks readyMasks; /* This array reflects the readable/writable
* conditions that were found to exist by the
* last call to select. */
int numFdBits; /* Number of valid bits in checkMasks
* (one more than highest fd for which
* Tcl_WatchFile has been called). */
#ifdef TCL_THREADS
int onList; /* True if it is in this list */
|
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
/*
* Start the Notifier thread if necessary.
*/
Tcl_MutexLock(¬ifierMutex);
if (notifierCount == 0) {
| | | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
/*
* Start the Notifier thread if necessary.
*/
Tcl_MutexLock(¬ifierMutex);
if (notifierCount == 0) {
if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL,
TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) {
panic("Tcl_InitNotifier: unable to start notifier thread");
}
}
notifierCount++;
/*
* Wait for the notifier pipe to be created.
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 264 265 266 267 |
/*
* If this is the last thread to use the notifier, close the notifier
* pipe and wait for the background thread to terminate.
*/
if (notifierCount == 0) {
if (triggerPipe < 0) {
panic("Tcl_FinalizeNotifier: notifier pipe not initialized");
}
| > | | > | | > > > > > | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
/*
* If this is the last thread to use the notifier, close the notifier
* pipe and wait for the background thread to terminate.
*/
if (notifierCount == 0) {
int result;
if (triggerPipe < 0) {
panic("Tcl_FinalizeNotifier: notifier pipe not initialized");
}
/*
* Send "q" message to the notifier thread so that it will
* terminate. The notifier will return from its call to select()
* and notice that a "q" message has arrived, it will then close
* its side of the pipe and terminate its thread. Note the we can
* not just close the pipe and check for EOF in the notifier
* thread because if a background child process was created with
* exec, select() would not register the EOF on the pipe until the
* child processes had terminated. [Bug: 4139] [Bug: 1222872]
*/
write(triggerPipe, "q", 1);
close(triggerPipe);
while(triggerPipe >= 0) {
Tcl_ConditionWait(¬ifierCV, ¬ifierMutex, NULL);
}
result = Tcl_JoinThread(notifierThread, NULL);
if (result) {
Tcl_Panic("Tcl_FinalizeNotifier: unable to join notifier thread");
}
}
/*
* Clean up any synchronization objects in the thread local storage.
*/
Tcl_ConditionFinalize(&(tsdPtr->waitCV));
|
| ︙ | ︙ | |||
349 350 351 352 353 354 355 |
{
/*
* The interval timer doesn't do anything in this implementation,
* because the only event loop is via Tcl_DoOneEvent, which passes
* timeout values to Tcl_WaitForEvent.
*/
| | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
{
/*
* The interval timer doesn't do anything in this implementation,
* because the only event loop is via Tcl_DoOneEvent, which passes
* timeout values to Tcl_WaitForEvent.
*/
if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
tclStubs.tcl_SetTimer(timePtr);
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
* proc should be called. */
Tcl_FileProc *proc; /* Procedure to call for each
* selected event. */
ClientData clientData; /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr;
| < | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 |
* proc should be called. */
Tcl_FileProc *proc; /* Procedure to call for each
* selected event. */
ClientData clientData; /* Arbitrary data to pass to proc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr;
if (tclStubs.tcl_CreateFileHandler != tclOriginalNotifier.createFileHandlerProc) {
tclStubs.tcl_CreateFileHandler(fd, mask, proc, clientData);
return;
}
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
|
| ︙ | ︙ | |||
434 435 436 437 438 439 440 |
filePtr->clientData = clientData;
filePtr->mask = mask;
/*
* Update the check masks for this file.
*/
| < < | | | | | | | | | | | 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 |
filePtr->clientData = clientData;
filePtr->mask = mask;
/*
* Update the check masks for this file.
*/
if ( mask & TCL_READABLE ) {
FD_SET( fd, &(tsdPtr->checkMasks.readable) );
} else {
FD_CLR( fd, &(tsdPtr->checkMasks.readable) );
}
if ( mask & TCL_WRITABLE ) {
FD_SET( fd, &(tsdPtr->checkMasks.writable) );
} else {
FD_CLR( fd, &(tsdPtr->checkMasks.writable) );
}
if ( mask & TCL_EXCEPTION ) {
FD_SET( fd, &(tsdPtr->checkMasks.exceptional) );
} else {
FD_CLR( fd, &(tsdPtr->checkMasks.exceptional) );
}
if (tsdPtr->numFdBits <= fd) {
tsdPtr->numFdBits = fd+1;
}
}
/*
|
| ︙ | ︙ | |||
478 479 480 481 482 483 484 |
*/
void
Tcl_DeleteFileHandler(fd)
int fd; /* Stream id for which to remove callback procedure. */
{
FileHandler *filePtr, *prevPtr;
| | < | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
*/
void
Tcl_DeleteFileHandler(fd)
int fd; /* Stream id for which to remove callback procedure. */
{
FileHandler *filePtr, *prevPtr;
int i;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tclStubs.tcl_DeleteFileHandler != tclOriginalNotifier.deleteFileHandlerProc) {
tclStubs.tcl_DeleteFileHandler(fd);
return;
}
/*
* Find the entry for the given file (and return if there isn't one).
*/
|
| ︙ | ︙ | |||
505 506 507 508 509 510 511 |
}
}
/*
* Update the check masks for this file.
*/
| < < < | | | | > | | | < < < < < < | | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 |
}
}
/*
* Update the check masks for this file.
*/
if (filePtr->mask & TCL_READABLE) {
FD_CLR( fd, &(tsdPtr->checkMasks.readable) );
}
if (filePtr->mask & TCL_WRITABLE) {
FD_CLR( fd, &(tsdPtr->checkMasks.writable) );
}
if (filePtr->mask & TCL_EXCEPTION) {
FD_CLR( fd, &(tsdPtr->checkMasks.exceptional) );
}
/*
* Find current max fd.
*/
if (fd+1 == tsdPtr->numFdBits) {
tsdPtr->numFdBits = 0;
for (i = fd-1; i >= 0; i--) {
if ( FD_ISSET( i, &(tsdPtr->checkMasks.readable) )
|| FD_ISSET( i, &(tsdPtr->checkMasks.writable) )
|| FD_ISSET( i, &(tsdPtr->checkMasks.exceptional ) ) ) {
tsdPtr->numFdBits = i+1;
break;
}
}
}
/*
* Clean up information in the callback record.
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
int
Tcl_WaitForEvent(timePtr)
Tcl_Time *timePtr; /* Maximum block time, or NULL. */
{
FileHandler *filePtr;
FileHandlerEvent *fileEvPtr;
| < | > > > > > | > < < > | > > > > > > > > > > | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
int
Tcl_WaitForEvent(timePtr)
Tcl_Time *timePtr; /* Maximum block time, or NULL. */
{
FileHandler *filePtr;
FileHandlerEvent *fileEvPtr;
int mask;
#ifdef TCL_THREADS
int waitForFiles;
#else
/* Impl. notes: timeout & timeoutPtr are used if, and only if
* threads are not enabled. They are the arguments for the regular
* select() used when the core is not thread-enabled. */
struct timeval timeout, *timeoutPtr;
int numFound;
#endif
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
return tclStubs.tcl_WaitForEvent(timePtr);
}
#ifndef TCL_THREADS
/*
* Set up the timeout structure. Note that if there are no events to
* check for, we return with a negative result rather than blocking
* forever.
*/
if (timePtr) {
timeout.tv_sec = timePtr->sec;
timeout.tv_usec = timePtr->usec;
timeoutPtr = &timeout;
} else if (tsdPtr->numFdBits == 0) {
/*
* If there are no threads, no timeout, and no fds registered,
* then there are no events possible and we must avoid deadlock.
* Note that this is not entirely correct because there might
* be a signal that could interrupt the select call, but we
* don't handle that case if we aren't using threads.
*/
return -1;
} else {
timeoutPtr = NULL;
}
#endif
#ifdef TCL_THREADS
/*
* Place this thread on the list of interested threads, signal the
* notifier thread, and wait for a response or a timeout.
*/
Tcl_MutexLock(¬ifierMutex);
waitForFiles = (tsdPtr->numFdBits > 0);
if (timePtr != NULL && timePtr->sec == 0 && (timePtr->usec == 0
#if defined(__APPLE__) && defined(__LP64__)
/*
* On 64-bit Darwin, pthread_cond_timedwait() appears to have a bug
* that causes it to wait forever when passed an absolute time which
* has already been exceeded by the system time; as a workaround,
* when given a very brief timeout, just do a poll. [Bug 1457797]
*/
|| timePtr->usec < 10
#endif
)) {
/*
* Cannot emulate a polling select with a polling condition variable.
* Instead, pretend to wait for files and tell the notifier
* thread what we are doing. The notifier thread makes sure
* it goes through select with its select mask in the same state
* as ours currently is. We block until that happens.
*/
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
tsdPtr->prevPtr = 0;
waitingListPtr = tsdPtr;
tsdPtr->onList = 1;
write(triggerPipe, "", 1);
}
| | > > | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
tsdPtr->prevPtr = 0;
waitingListPtr = tsdPtr;
tsdPtr->onList = 1;
write(triggerPipe, "", 1);
}
FD_ZERO( &(tsdPtr->readyMasks.readable) );
FD_ZERO( &(tsdPtr->readyMasks.writable) );
FD_ZERO( &(tsdPtr->readyMasks.exceptional) );
if (!tsdPtr->eventReady) {
Tcl_ConditionWait(&tsdPtr->waitCV, ¬ifierMutex, timePtr);
}
tsdPtr->eventReady = 0;
if (waitForFiles && tsdPtr->onList) {
|
| ︙ | ︙ | |||
762 763 764 765 766 767 768 |
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
write(triggerPipe, "", 1);
}
#else
| | < | | | | > | > > | < | < | | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 |
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
write(triggerPipe, "", 1);
}
#else
tsdPtr->readyMasks = tsdPtr->checkMasks;
numFound = select( tsdPtr->numFdBits,
&(tsdPtr->readyMasks.readable),
&(tsdPtr->readyMasks.writable),
&(tsdPtr->readyMasks.exceptional),
timeoutPtr );
/*
* Some systems don't clear the masks after an error, so
* we have to do it here.
*/
if (numFound == -1) {
FD_ZERO( &(tsdPtr->readyMasks.readable ) );
FD_ZERO( &(tsdPtr->readyMasks.writable ) );
FD_ZERO( &(tsdPtr->readyMasks.exceptional ) );
}
#endif
/*
* Queue all detected file events before returning.
*/
for (filePtr = tsdPtr->firstFileHandlerPtr; (filePtr != NULL);
filePtr = filePtr->nextPtr) {
mask = 0;
if ( FD_ISSET( filePtr->fd, &(tsdPtr->readyMasks.readable) ) ) {
mask |= TCL_READABLE;
}
if ( FD_ISSET( filePtr->fd, &(tsdPtr->readyMasks.writable) ) ) {
mask |= TCL_WRITABLE;
}
if ( FD_ISSET( filePtr->fd, &(tsdPtr->readyMasks.exceptional) ) ) {
mask |= TCL_EXCEPTION;
}
if (!mask) {
continue;
}
|
| ︙ | ︙ | |||
854 855 856 857 858 859 860 |
*/
static void
NotifierThreadProc(clientData)
ClientData clientData; /* Not used. */
{
ThreadSpecificData *tsdPtr;
| | | > | > < | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 |
*/
static void
NotifierThreadProc(clientData)
ClientData clientData; /* Not used. */
{
ThreadSpecificData *tsdPtr;
fd_set readableMask;
fd_set writableMask;
fd_set exceptionalMask;
int fds[2];
int i, status, numFdBits = 0, receivePipe;
long found;
struct timeval poll = {0., 0.}, *timePtr;
char buf[2];
if (pipe(fds) != 0) {
panic("NotifierThreadProc: could not create trigger pipe.");
}
receivePipe = fds[0];
|
| ︙ | ︙ | |||
907 908 909 910 911 912 913 |
Tcl_MutexUnlock(¬ifierMutex);
/*
* Look for file events and report them to interested threads.
*/
while (1) {
| < < < < < < < | > > > | | | | > | > > > > > > > | | | | > > > | > > | > | < > | | | > > | > > > | > | > > > > > > > | | | | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 |
Tcl_MutexUnlock(¬ifierMutex);
/*
* Look for file events and report them to interested threads.
*/
while (1) {
FD_ZERO( &readableMask );
FD_ZERO( &writableMask );
FD_ZERO( &exceptionalMask );
/*
* Compute the logical OR of the select masks from all the
* waiting notifiers.
*/
Tcl_MutexLock(¬ifierMutex);
timePtr = NULL;
for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
for ( i = tsdPtr->numFdBits-1; i >= 0; --i ) {
if ( FD_ISSET( i, &(tsdPtr->checkMasks.readable) ) ) {
FD_SET( i, &readableMask );
}
if ( FD_ISSET( i, &(tsdPtr->checkMasks.writable) ) ) {
FD_SET( i, &writableMask );
}
if ( FD_ISSET( i, &(tsdPtr->checkMasks.exceptional) ) ) {
FD_SET( i, &exceptionalMask );
}
}
if ( tsdPtr->numFdBits > numFdBits ) {
numFdBits = tsdPtr->numFdBits;
}
if (tsdPtr->pollState & POLL_WANT) {
/*
* Here we make sure we go through select() with the same
* mask bits that were present when the thread tried to poll.
*/
tsdPtr->pollState |= POLL_DONE;
timePtr = &poll;
}
}
Tcl_MutexUnlock(¬ifierMutex);
/*
* Set up the select mask to include the receive pipe.
*/
if ( receivePipe >= numFdBits ) {
numFdBits = receivePipe + 1;
}
FD_SET( receivePipe, &readableMask );
if ( select( numFdBits, &readableMask, &writableMask,
&exceptionalMask, timePtr) == -1 ) {
/*
* Try again immediately on an error.
*/
continue;
}
/*
* Alert any threads that are waiting on a ready file descriptor.
*/
Tcl_MutexLock(¬ifierMutex);
for (tsdPtr = waitingListPtr; tsdPtr; tsdPtr = tsdPtr->nextPtr) {
found = 0;
for ( i = tsdPtr->numFdBits-1; i >= 0; --i ) {
if ( FD_ISSET( i, &(tsdPtr->checkMasks.readable) )
&& FD_ISSET( i, &readableMask ) ) {
FD_SET( i, &(tsdPtr->readyMasks.readable) );
found = 1;
}
if ( FD_ISSET( i, &(tsdPtr->checkMasks.writable) )
&& FD_ISSET( i, &writableMask ) ) {
FD_SET( i, &(tsdPtr->readyMasks.writable) );
found = 1;
}
if ( FD_ISSET( i, &(tsdPtr->checkMasks.exceptional) )
&& FD_ISSET( i, &exceptionalMask ) ) {
FD_SET( i, &(tsdPtr->readyMasks.exceptional) );
found = 1;
}
}
if (found || (tsdPtr->pollState & POLL_DONE)) {
tsdPtr->eventReady = 1;
if (tsdPtr->onList) {
/*
* Remove the ThreadSpecificData structure of this
* thread from the waiting list. This prevents us from
* continuously spining on select until the other
* threads runs and services the file event.
*/
if (tsdPtr->prevPtr) {
tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
} else {
waitingListPtr = tsdPtr->nextPtr;
}
if (tsdPtr->nextPtr) {
tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
}
tsdPtr->nextPtr = tsdPtr->prevPtr = NULL;
tsdPtr->onList = 0;
tsdPtr->pollState = 0;
}
Tcl_ConditionNotify(&tsdPtr->waitCV);
}
}
Tcl_MutexUnlock(¬ifierMutex);
/*
* Consume the next byte from the notifier pipe if the pipe was
* readable. Note that there may be multiple bytes pending, but
* to avoid a race condition we only read one at a time.
*/
if ( FD_ISSET( receivePipe, &readableMask ) ) {
i = read(receivePipe, buf, 1);
if ((i == 0) || ((i == 1) && (buf[0] == 'q'))) {
/*
* Someone closed the write end of the pipe or sent us a
* Quit message [Bug: 4139] and then closed the write end
* of the pipe so we need to shut down the notifier thread.
|
| ︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 |
*/
close(receivePipe);
Tcl_MutexLock(¬ifierMutex);
triggerPipe = -1;
Tcl_ConditionNotify(¬ifierCV);
Tcl_MutexUnlock(¬ifierMutex);
| | > > > > | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 |
*/
close(receivePipe);
Tcl_MutexLock(¬ifierMutex);
triggerPipe = -1;
Tcl_ConditionNotify(¬ifierCV);
Tcl_MutexUnlock(¬ifierMutex);
TclpThreadExit (0);
}
#endif
#endif /* HAVE_COREFOUNDATION */
|
Changes to unix/tclUnixPipe.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclUnixPipe.c -- * * This file implements the UNIX-specific exec pipeline functions, * the "pipe" channel driver, and the "pid" Tcl command. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclUnixPipe.c -- * * This file implements the UNIX-specific exec pipeline functions, * the "pipe" channel driver, and the "pid" Tcl command. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUnixPipe.c,v 1.23.2.7 2006/08/02 20:04:40 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #ifdef USE_VFORK #define fork vfork |
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
/*
* This structure describes the channel type structure for command pipe
* based IO:
*/
static Tcl_ChannelType pipeChannelType = {
"pipe", /* Type name. */
| | > > | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
/*
* This structure describes the channel type structure for command pipe
* based IO:
*/
static Tcl_ChannelType pipeChannelType = {
"pipe", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
PipeCloseProc, /* Close proc. */
PipeInputProc, /* Input proc. */
PipeOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
PipeWatchProc, /* Initialize notifier. */
PipeGetHandleProc, /* Get OS handles out of channel. */
NULL, /* close2proc. */
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
NULL, /* thread action proc */
};
/*
*----------------------------------------------------------------------
*
* TclpMakeFile --
*
|
| ︙ | ︙ | |||
150 151 152 153 154 155 156 |
fcntl(fd, F_SETFD, FD_CLOEXEC);
/*
* If the file is being opened for writing, seek to the end
* so we can append to any data already in the file.
*/
| | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
fcntl(fd, F_SETFD, FD_CLOEXEC);
/*
* If the file is being opened for writing, seek to the end
* so we can append to any data already in the file.
*/
if ((mode & O_WRONLY) && !(mode & O_APPEND)) {
TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_END);
}
/*
* Increment the fd so it can't be 0, which would conflict with
* the NULL return for errors.
*/
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
* errors from the child will be discarded.
* errorFile may be the same as outputFile. */
Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr
* is filled with the process id of the child
* process. */
{
TclFile errPipeIn, errPipeOut;
| | | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
* errors from the child will be discarded.
* errorFile may be the same as outputFile. */
Tcl_Pid *pidPtr; /* If this procedure is successful, pidPtr
* is filled with the process id of the child
* process. */
{
TclFile errPipeIn, errPipeOut;
int count, status, fd;
char errSpace[200 + TCL_INTEGER_SPACE];
Tcl_DString *dsArray;
char **newArgv;
int pid, i;
errPipeIn = NULL;
errPipeOut = NULL;
|
| ︙ | ︙ | |||
424 425 426 427 428 429 430 |
dsArray = (Tcl_DString *) ckalloc(argc * sizeof(Tcl_DString));
newArgv = (char **) ckalloc((argc+1) * sizeof(char *));
newArgv[argc] = NULL;
for (i = 0; i < argc; i++) {
newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
}
| > > > > > > > > > > | > > > > > > > > | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 |
dsArray = (Tcl_DString *) ckalloc(argc * sizeof(Tcl_DString));
newArgv = (char **) ckalloc((argc+1) * sizeof(char *));
newArgv[argc] = NULL;
for (i = 0; i < argc; i++) {
newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
}
#ifdef USE_VFORK
/*
* After vfork(), do not call code in the child that changes global state,
* because it is using the parent's memory space at that point and writes
* might corrupt the parent: so ensure standard channels are initialized in
* the parent, otherwise SetupStdFile() might initialize them in the child.
*/
if (!inputFile) {
Tcl_GetStdChannel(TCL_STDIN);
}
if (!outputFile) {
Tcl_GetStdChannel(TCL_STDOUT);
}
if (!errorFile) {
Tcl_GetStdChannel(TCL_STDERR);
}
#endif
pid = fork();
if (pid == 0) {
int joinThisError = errorFile && (errorFile == outputFile);
fd = GetFd(errPipeOut);
/*
* Set up stdio file handles for the child process.
*/
if (!SetupStdFile(inputFile, TCL_STDIN)
|
| ︙ | ︙ | |||
656 657 658 659 660 661 662 |
* Must clear the close-on-exec flag for the target FD, since
* some systems (e.g. Ultrix) do not clear the CLOEXEC flag on
* the target FD.
*/
fcntl(targetFd, F_SETFD, 0);
} else {
| < < | | 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
* Must clear the close-on-exec flag for the target FD, since
* some systems (e.g. Ultrix) do not clear the CLOEXEC flag on
* the target FD.
*/
fcntl(targetFd, F_SETFD, 0);
} else {
/*
* Since we aren't dup'ing the file, we need to explicitly clear
* the close-on-exec flag.
*/
fcntl(fd, F_SETFD, 0);
}
} else {
close(targetFd);
}
return 1;
}
|
| ︙ | ︙ | |||
1243 1244 1245 1246 1247 1248 1249 |
for (i = 0; i < pipePtr->numPids; i++) {
longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
}
}
return TCL_OK;
}
| > > > > > > > > > > > > > > > > > > > > > | 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 |
for (i = 0; i < pipePtr->numPids; i++) {
longObjPtr = Tcl_NewLongObj((long) TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(NULL, resultPtr, longObjPtr);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizePipes --
*
* Cleans up the pipe subsystem from Tcl_FinalizeThread
*
* Results:
* None.
*
* This procedure carries out no operation on Unix.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizePipes()
{
}
|
Changes to unix/tclUnixPort.h.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 | * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUnixPort.h,v 1.27.2.18 2007/04/21 22:42:49 kennykb Exp $ */ #ifndef _TCLUNIXPORT #define _TCLUNIXPORT #ifndef _TCLINT # include "tclInt.h" |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | # include <dirent.h> #endif #endif #ifdef HAVE_STRUCT_DIRENT64 typedef struct dirent64 Tcl_DirEntry; # define TclOSreaddir readdir64 | < < | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 | # include <dirent.h> #endif #endif #ifdef HAVE_STRUCT_DIRENT64 typedef struct dirent64 Tcl_DirEntry; # define TclOSreaddir readdir64 #else typedef struct dirent Tcl_DirEntry; # define TclOSreaddir readdir #endif #ifdef HAVE_TYPE_OFF64_T typedef off64_t Tcl_SeekOffset; # define TclOSseek lseek64 # define TclOSopen open64 #else |
| ︙ | ︙ | |||
93 94 95 96 97 98 99 100 101 102 103 104 105 106 | #endif #include <sys/file.h> #ifdef HAVE_SYS_SELECT_H # include <sys/select.h> #endif #include <sys/stat.h> #if TIME_WITH_SYS_TIME # include <sys/time.h> # include <time.h> #else #if HAVE_SYS_TIME_H # include <sys/time.h> #else | > > > > > > > > | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
#endif
#include <sys/file.h>
#ifdef HAVE_SYS_SELECT_H
# include <sys/select.h>
#endif
#include <sys/stat.h>
#ifdef __CYGWIN__
# define timezone _timezone
typedef long TIMEZONE_t;
#else /* !__CYGWIN__ */
typedef int TIMEZONE_t;
#endif /* !__CYGWIN__ */
#if TIME_WITH_SYS_TIME
# include <sys/time.h>
# include <time.h>
#else
#if HAVE_SYS_TIME_H
# include <sys/time.h>
#else
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | /* * Not all systems declare the errno variable in errno.h. so this * file does it explicitly. The list of system error messages also * isn't generally declared in a header file anywhere. */ extern int errno; /* * Not all systems declare all the errors that Tcl uses! Provide some * work-arounds... */ #ifndef EOVERFLOW | > > | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 | /* * Not all systems declare the errno variable in errno.h. so this * file does it explicitly. The list of system error messages also * isn't generally declared in a header file anywhere. */ #ifdef NO_ERRNO extern int errno; #endif /* * Not all systems declare all the errors that Tcl uses! Provide some * work-arounds... */ #ifndef EOVERFLOW |
| ︙ | ︙ | |||
500 501 502 503 504 505 506 507 508 509 510 511 512 513 | /* * There is no platform-specific panic routine for Unix in the Tcl internals. */ #define TclpPanic ((Tcl_PanicProc *) NULL) /* *--------------------------------------------------------------------------- * The following macros and declarations represent the interface between * generic and unix-specific parts of Tcl. Some of the macros may override * functions declared in tclInt.h. *--------------------------------------------------------------------------- */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
/*
* There is no platform-specific panic routine for Unix in the Tcl internals.
*/
#define TclpPanic ((Tcl_PanicProc *) NULL)
/*
* Darwin specifc configure overrides.
*/
#ifdef __APPLE__
/*
* Support for fat compiles: configure runs only once for multiple architectures
*/
# if defined(__LP64__) && defined (NO_COREFOUNDATION_64)
# undef HAVE_COREFOUNDATION
# endif /* __LP64__ && NO_COREFOUNDATION_64 */
# include <sys/cdefs.h>
# ifdef __DARWIN_UNIX03
# if __DARWIN_UNIX03
# undef HAVE_PUTENV_THAT_COPIES
# else
# define HAVE_PUTENV_THAT_COPIES 1
# endif
# endif /* __DARWIN_UNIX03 */
/*
* The termios configure test program relies on the configure script being run
* from a terminal, which is not the case e.g. when configuring from Xcode.
* Since termios is known to be present on all Mac OS X releases since 10.0,
* override the configure defines for serial API here. [Bug 497147]
*/
# define USE_TERMIOS 1
# undef USE_TERMIO
# undef USE_SGTTY
/*
* Include AvailabilityMacros.h here (when available) to ensure any symbolic
* MAC_OS_X_VERSION_* constants passed on the command line are translated.
*/
# ifdef HAVE_AVAILABILITYMACROS_H
# include <AvailabilityMacros.h>
# endif
/*
* Support for weak import.
*/
# ifdef HAVE_WEAK_IMPORT
# if !defined(HAVE_AVAILABILITYMACROS_H) || !defined(MAC_OS_X_VERSION_MIN_REQUIRED)
# undef HAVE_WEAK_IMPORT
# else
# ifndef WEAK_IMPORT_ATTRIBUTE
# define WEAK_IMPORT_ATTRIBUTE __attribute__((weak_import))
# endif
# endif
# endif /* HAVE_WEAK_IMPORT */
/*
* Support for MAC_OS_X_VERSION_MAX_ALLOWED define from AvailabilityMacros.h:
* only use API available in the indicated OS version or earlier.
*/
# ifdef MAC_OS_X_VERSION_MAX_ALLOWED
# if MAC_OS_X_VERSION_MAX_ALLOWED < 1050 && defined(__LP64__)
# undef HAVE_COREFOUNDATION
# endif
# if MAC_OS_X_VERSION_MAX_ALLOWED < 1040
# undef HAVE_OSSPINLOCKLOCK
# undef HAVE_PTHREAD_ATFORK
# undef HAVE_COPYFILE
# endif
# if MAC_OS_X_VERSION_MAX_ALLOWED < 1030
# ifdef TCL_THREADS
/* prior to 10.3, realpath is not threadsafe, c.f. bug 711232 */
# define NO_REALPATH 1
# endif
# undef HAVE_LANGINFO
# endif
# endif /* MAC_OS_X_VERSION_MAX_ALLOWED */
# if defined(HAVE_COREFOUNDATION) && defined(__LP64__) && \
defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1050
# warning "Weak import of 64-bit CoreFoundation is not supported, will not run on Mac OS X < 10.5."
# endif
/*
* At present, using vfork() instead of fork() causes execve() to fail
* intermittently on Darwin x86_64. rdar://4685553
*/
# if defined(__x86_64__) && !defined(FIXED_RDAR_4685553)
# undef USE_VFORK
# endif /* __x86_64__ */
#endif /* __APPLE__ */
/*
* Darwin 8 copyfile API.
*/
#ifdef HAVE_COPYFILE
#ifdef HAVE_COPYFILE_H
#include <copyfile.h>
#if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040
/* Support for weakly importing copyfile. */
#define WEAK_IMPORT_COPYFILE
extern int copyfile(const char *from, const char *to, copyfile_state_t state,
copyfile_flags_t flags) WEAK_IMPORT_ATTRIBUTE;
#endif /* HAVE_WEAK_IMPORT */
#else /* HAVE_COPYFILE_H */
int copyfile(const char *from, const char *to, void *state, uint32_t flags);
#define COPYFILE_ACL (1<<0)
#define COPYFILE_XATTR (1<<2)
#define COPYFILE_NOFOLLOW_SRC (1<<18)
#if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1040
/* Support for weakly importing copyfile. */
#define WEAK_IMPORT_COPYFILE
extern int copyfile(const char *from, const char *to, void *state,
uint32_t flags) WEAK_IMPORT_ATTRIBUTE;
#endif /* HAVE_WEAK_IMPORT */
#endif /* HAVE_COPYFILE_H */
#endif /* HAVE_COPYFILE */
/*
*---------------------------------------------------------------------------
* The following macros and declarations represent the interface between
* generic and unix-specific parts of Tcl. Some of the macros may override
* functions declared in tclInt.h.
*---------------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
558 559 560 561 562 563 564 | #ifdef TCL_THREADS #include <pthread.h> typedef pthread_mutex_t TclpMutex; EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN Tcl_DirEntry * TclpReaddir(DIR *); | > | > > | > < < < < < > > > > > > > > > > > > > > > > > > > | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 | #ifdef TCL_THREADS #include <pthread.h> typedef pthread_mutex_t TclpMutex; EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr)); EXTERN Tcl_DirEntry * TclpReaddir(DIR *); #ifndef TclpLocaltime EXTERN struct tm * TclpLocaltime(TclpTime_t_CONST); #endif #ifndef TclpGmtime EXTERN struct tm * TclpGmtime(TclpTime_t_CONST); #endif EXTERN char * TclpInetNtoa(struct in_addr); #define inet_ntoa(x) TclpInetNtoa(x) #else typedef int TclpMutex; #define TclpMutexInit(a) #define TclpMutexLock(a) #define TclpMutexUnlock(a) #endif /* TCL_THREADS */ /* * Set of MT-safe implementations of some * known-to-be-MT-unsafe library calls. * Instead of returning pointers to the * static storage, those return pointers * to the TSD data. */ #include <pwd.h> #include <grp.h> EXTERN struct passwd* TclpGetPwNam(const char *name); EXTERN struct group* TclpGetGrNam(const char *name); EXTERN struct passwd* TclpGetPwUid(uid_t uid); EXTERN struct group* TclpGetGrGid(gid_t gid); EXTERN struct hostent* TclpGetHostByName(const char *name); EXTERN struct hostent* TclpGetHostByAddr(const char *addr, int length, int type); #include "tclPlatDecls.h" #include "tclIntPlatDecls.h" #endif /* _TCLUNIXPORT */ |
Changes to unix/tclUnixSock.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclUnixSock.c -- * * This file contains Unix-specific socket related code. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclUnixSock.c -- * * This file contains Unix-specific socket related code. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUnixSock.c,v 1.6.2.4 2006/09/07 09:01:07 vasiljevic Exp $ */ #include "tcl.h" #include "tclPort.h" /* * There is no portable macro for the maximum length |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
return hostname;
}
native = NULL;
#ifndef NO_UNAME
(VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname));
if (uname(&u) > -1) { /* INTL: Native. */
| | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
return hostname;
}
native = NULL;
#ifndef NO_UNAME
(VOID *) memset((VOID *) &u, (int) 0, sizeof(struct utsname));
if (uname(&u) > -1) { /* INTL: Native. */
hp = TclpGetHostByName(u.nodename); /* INTL: Native. */
if (hp == NULL) {
/*
* Sometimes the nodename is fully qualified, but gets truncated
* as it exceeds SYS_NMLN. See if we can just get the immediate
* nodename and get a proper answer that way.
*/
char *dot = strchr(u.nodename, '.');
if (dot != NULL) {
char *node = ckalloc((unsigned) (dot - u.nodename + 1));
memcpy(node, u.nodename, (size_t) (dot - u.nodename));
node[dot - u.nodename] = '\0';
hp = TclpGetHostByName(node);
ckfree(node);
}
}
if (hp != NULL) {
native = hp->h_name;
} else {
native = u.nodename;
|
| ︙ | ︙ | |||
144 145 146 147 148 149 150 |
int
TclpHasSockets(interp)
Tcl_Interp *interp; /* Not used. */
{
return TCL_OK;
}
| > > > > > > > > > > > > > > > > > > > > > > | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
int
TclpHasSockets(interp)
Tcl_Interp *interp; /* Not used. */
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeSockets --
*
* Performs per-thread socket subsystem finalization.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeSockets()
{
return;
}
|
Changes to unix/tclUnixTest.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclUnixTest.c -- * * Contains platform specific test commands for the Unix platform. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclUnixTest.c -- * * Contains platform specific test commands for the Unix platform. * * Copyright (c) 1996-1997 Sun Microsystems, Inc. * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclUnixTest.c,v 1.14.2.2 2006/03/19 22:47:30 vincentdarley Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The headers are needed for the testalarm command that verifies the |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 86 87 88 89 90 91 92 | Tcl_Interp *interp, int argc, CONST char **argv)); int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); static int TestalarmCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestgotsigCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static void AlarmHandler _ANSI_ARGS_(()); /* *---------------------------------------------------------------------- * * TclplatformtestInit -- * * Defines commands that test platform specific functionality for | > > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | Tcl_Interp *interp, int argc, CONST char **argv)); int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); static int TestalarmCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestgotsigCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static void AlarmHandler _ANSI_ARGS_(()); static int TestchmodCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); /* *---------------------------------------------------------------------- * * TclplatformtestInit -- * * Defines commands that test platform specific functionality for |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
*----------------------------------------------------------------------
*/
int
TclplatformtestInit(interp)
Tcl_Interp *interp; /* Interpreter to add commands to. */
{
Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
| > > | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
*----------------------------------------------------------------------
*/
int
TclplatformtestInit(interp)
Tcl_Interp *interp; /* Interpreter to add commands to. */
{
Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfilehandler", TestfilehandlerCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfilewait", TestfilewaitCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfindexecutable", TestfindexecutableCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetopenfile", TestgetopenfileCmd,
|
| ︙ | ︙ | |||
643 644 645 646 647 648 649 |
memset((void *)&action.sa_mask, 0, sizeof(sigset_t));
action.sa_flags = SA_RESTART;
if (sigaction(SIGALRM, &action, NULL) < 0) {
Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
| | < < < | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
memset((void *)&action.sa_mask, 0, sizeof(sigset_t));
action.sa_flags = SA_RESTART;
if (sigaction(SIGALRM, &action, NULL) < 0) {
Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
(void)alarm(sec);
return TCL_OK;
#else
Tcl_AppendResult(interp, "warning: sigaction SA_RESTART not support on this platform", NULL);
return TCL_ERROR;
#endif
}
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 |
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, gotsig, (char *) NULL);
gotsig = "0";
return TCL_OK;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 |
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, gotsig, (char *) NULL);
gotsig = "0";
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* TestchmodCmd --
*
* Implements the "testchmod" cmd. Used when testing "file" command.
* The only attribute used by the Windows platform is the user write
* flag; if this is not set, the file is made read-only. Otehrwise, the
* file is made read-write.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Changes permissions of specified files.
*
*---------------------------------------------------------------------------
*/
static int
TestchmodCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int i, mode;
char *rest;
if (argc < 2) {
usage:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" mode file ?file ...?", NULL);
return TCL_ERROR;
}
mode = (int) strtol(argv[1], &rest, 8);
if ((rest == argv[1]) || (*rest != '\0')) {
goto usage;
}
for (i = 2; i < argc; i++) {
Tcl_DString buffer;
CONST char *translated;
translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
if (chmod(translated, (unsigned) mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
NULL);
return TCL_ERROR;
}
Tcl_DStringFree(&buffer);
}
return TCL_OK;
}
|
Changes to unix/tclUnixThrd.c.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
#include "tclPort.h"
#ifdef TCL_THREADS
#include "pthread.h"
typedef struct ThreadSpecificData {
| | < < < < < < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
#include "tclPort.h"
#ifdef TCL_THREADS
#include "pthread.h"
typedef struct ThreadSpecificData {
char nabuf[16];
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* masterLock is used to serialize creation of mutexes, condition
* variables, and thread local storage.
|
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | #endif /* TCL_THREADS */ /* *---------------------------------------------------------------------- * | | | > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
#endif /* TCL_THREADS */
/*
*----------------------------------------------------------------------
*
* TclpThreadCreate --
*
* This procedure creates a new thread.
*
* Results:
* TCL_OK if the thread could be created. The thread ID is
* returned in a parameter.
*
* Side effects:
* A new thread is created.
*
*----------------------------------------------------------------------
*/
int
TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
Tcl_ThreadId *idPtr; /* Return, the ID of the thread */
Tcl_ThreadCreateProc proc; /* Main() function of the thread */
ClientData clientData; /* The one argument to Main() */
int stackSize; /* Size of stack for the new thread */
int flags; /* Flags controlling behaviour of
* the new thread */
{
#ifdef TCL_THREADS
pthread_attr_t attr;
pthread_t theThread;
int result;
pthread_attr_init(&attr);
pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
#ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE
if (stackSize != TCL_THREAD_STACK_DEFAULT) {
|
| ︙ | ︙ | |||
124 125 126 127 128 129 130 |
}
#endif
if (! (flags & TCL_THREAD_JOINABLE)) {
pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED);
}
| | | > | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
}
#endif
if (! (flags & TCL_THREAD_JOINABLE)) {
pthread_attr_setdetachstate (&attr, PTHREAD_CREATE_DETACHED);
}
if (pthread_create(&theThread, &attr,
(void * (*)())proc, (void *)clientData) &&
pthread_create(&theThread, NULL,
(void * (*)())proc, (void *)clientData)) {
result = TCL_ERROR;
} else {
*idPtr = (Tcl_ThreadId)theThread;
result = TCL_OK;
}
pthread_attr_destroy(&attr);
return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 | * The result area is set to the exit code of the thread we * waited upon. * *---------------------------------------------------------------------- */ int | | | | | | > | > > > | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
* The result area is set to the exit code of the thread we
* waited upon.
*
*----------------------------------------------------------------------
*/
int
Tcl_JoinThread(threadId, state)
Tcl_ThreadId threadId; /* Id of the thread to wait upon */
int* state; /* Reference to the storage the result
* of the thread we wait upon will be
* written into. */
{
#ifdef TCL_THREADS
int result;
unsigned long retcode;
result = pthread_join((pthread_t) threadId, (void**) &retcode);
if (state) {
*state = (int) retcode;
}
return (result == 0) ? TCL_OK : TCL_ERROR;
#else
return TCL_ERROR;
#endif
}
#ifdef TCL_THREADS
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
void
TclpInitLock()
{
#ifdef TCL_THREADS
pthread_mutex_lock(&initLock);
#endif
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
void
TclpInitLock()
{
#ifdef TCL_THREADS
pthread_mutex_lock(&initLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeLock
*
* This procedure is used to destroy all private resources used in
* this file.
*
* Results:
* None.
*
* Side effects:
* Destroys everything private. TclpInitLock must be held
* entering this function.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeLock ()
{
#ifdef TCL_THREADS
/*
* You do not need to destroy mutexes that were created with the
* PTHREAD_MUTEX_INITIALIZER macro. These mutexes do not need
* any destruction: masterLock, allocLock, and initLock.
*/
pthread_mutex_unlock(&initLock);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpInitUnlock
*
* This procedure is used to release a lock that serializes initialization
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
void
TclpFinalizeMutex(mutexPtr)
Tcl_Mutex *mutexPtr;
{
pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr;
if (pmutexPtr != NULL) {
ckfree((char *)pmutexPtr);
*mutexPtr = NULL;
}
}
/*
| > | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 |
void
TclpFinalizeMutex(mutexPtr)
Tcl_Mutex *mutexPtr;
{
pthread_mutex_t *pmutexPtr = *(pthread_mutex_t **)mutexPtr;
if (pmutexPtr != NULL) {
pthread_mutex_destroy(pmutexPtr);
ckfree((char *)pmutexPtr);
*mutexPtr = NULL;
}
}
/*
|
| ︙ | ︙ | |||
784 785 786 787 788 789 790 791 792 793 | * * Results: * See documentation of C functions. * * Side effects: * See documentation of C functions. * *---------------------------------------------------------------------- */ | > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < | | | | > > > > < < < | | | | > > > > > > > | > | > > > > | > > > > > > | > | > > > > > | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 |
*
* Results:
* See documentation of C functions.
*
* Side effects:
* See documentation of C functions.
*
* Notes:
* TclpReaddir is no longer used by the core (see 1095909),
* but it appears in the internal stubs table (see #589526).
*----------------------------------------------------------------------
*/
Tcl_DirEntry *
TclpReaddir(DIR * dir)
{
return TclOSreaddir(dir);
}
char *
TclpInetNtoa(struct in_addr addr)
{
#ifdef TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
unsigned char *b = (unsigned char*) &addr.s_addr;
sprintf(tsdPtr->nabuf, "%u.%u.%u.%u", b[0], b[1], b[2], b[3]);
return tsdPtr->nabuf;
#else
return inet_ntoa(addr);
#endif
}
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG)
/*
* Additions by AOL for specialized thread memory allocator.
*/
#ifdef USE_THREAD_ALLOC
static volatile int initialized = 0;
static pthread_key_t key;
typedef struct allocMutex {
Tcl_Mutex tlock;
pthread_mutex_t plock;
} allocMutex;
Tcl_Mutex *
TclpNewAllocMutex(void)
{
struct allocMutex *lockPtr;
lockPtr = malloc(sizeof(struct allocMutex));
if (lockPtr == NULL) {
panic("could not allocate lock");
}
lockPtr->tlock = (Tcl_Mutex) &lockPtr->plock;
pthread_mutex_init(&lockPtr->plock, NULL);
return &lockPtr->tlock;
}
void
TclpFreeAllocMutex(mutex)
Tcl_Mutex *mutex; /* The alloc mutex to free. */
{
allocMutex* lockPtr = (allocMutex*) mutex;
if (!lockPtr) return;
pthread_mutex_destroy(&lockPtr->plock);
free(lockPtr);
}
void TclpFreeAllocCache(ptr)
void *ptr;
{
if (ptr != NULL) {
/*
* Called by the pthread lib when a thread exits
*/
TclFreeAllocCache(ptr);
} else if (initialized) {
/*
* Called by us in TclFinalizeThreadAlloc() during
* the library finalization initiated from Tcl_Finalize()
*/
pthread_key_delete(key);
initialized = 0;
}
}
void *
TclpGetAllocCache(void)
{
if (!initialized) {
pthread_mutex_lock(allocLockPtr);
if (!initialized) {
pthread_key_create(&key, TclpFreeAllocCache);
initialized = 1;
}
pthread_mutex_unlock(allocLockPtr);
}
return pthread_getspecific(key);
}
void
TclpSetAllocCache(void *arg)
{
pthread_setspecific(key, arg);
}
#endif /* USE_THREAD_ALLOC */
#endif /* TCL_THREADS */
|
Changes to unix/tclUnixTime.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclUnixTime.c -- * * Contains Unix specific versions of Tcl functions that * obtain time values from the operating system. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > < | > > > > < | < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
/*
* tclUnixTime.c --
*
* Contains Unix specific versions of Tcl functions that
* obtain time values from the operating system.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclUnixTime.c,v 1.15.2.6 2007/04/21 19:52:15 kennykb Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include <locale.h>
#define TM_YEAR_BASE 1900
#define IsLeapYear(x) ((x % 4 == 0) && (x % 100 != 0 || x % 400 == 0))
/*
* TclpGetDate is coded to return a pointer to a 'struct tm'. For
* thread safety, this structure must be in thread-specific data.
* The 'tmKey' variable is the key to this buffer.
*/
static Tcl_ThreadDataKey tmKey;
typedef struct ThreadSpecificData {
struct tm gmtime_buf;
struct tm localtime_buf;
} ThreadSpecificData;
/*
* If we fall back on the thread-unsafe versions of gmtime and localtime,
* use this mutex to try to protect them.
*/
TCL_DECLARE_MUTEX(tmMutex)
static char* lastTZ = NULL; /* Holds the last setting of the
* TZ environment variable, or an
* empty string if the variable was
* not set. */
/* Static functions declared in this file */
static void SetTZIfNecessary _ANSI_ARGS_((void));
static void CleanupMemory _ANSI_ARGS_((ClientData));
/*
*-----------------------------------------------------------------------------
*
* TclpGetSeconds --
*
* This procedure returns the number of seconds from the epoch. On
|
| ︙ | ︙ | |||
122 123 124 125 126 127 128 | * None. * *---------------------------------------------------------------------- */ int TclpGetTimeZone (currentTime) | | | | | | | > | > > > | > > > > | < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < > | < > < > | | > | > | | < > > > > | | < | > | > | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclpGetTimeZone (currentTime)
Tcl_WideInt currentTime;
{
/*
* We prefer first to use the time zone in "struct tm" if the
* structure contains such a member. Following that, we try
* to locate the external 'timezone' variable and use its value.
* If both of those methods fail, we attempt to convert a known
* time to local time and use the difference from UTC as the local
* time zone. In all cases, we need to undo any Daylight Saving Time
* adjustment.
*/
#if defined(HAVE_TM_TZADJ)
# define TCL_GOT_TIMEZONE
/* Struct tm contains tm_tzadj - that value may be used. */
time_t curTime = (time_t) currentTime;
struct tm *timeDataPtr = TclpLocaltime((TclpTime_t) &curTime);
int timeZone;
timeZone = timeDataPtr->tm_tzadj / 60;
if (timeDataPtr->tm_isdst) {
timeZone += 60;
}
return timeZone;
#endif
#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE)
# define TCL_GOT_TIMEZONE
/* Struct tm contains tm_gmtoff - that value may be used. */
time_t curTime = (time_t) currentTime;
struct tm *timeDataPtr = TclpLocaltime((TclpTime_t) &curTime);
int timeZone;
timeZone = -(timeDataPtr->tm_gmtoff / 60);
if (timeDataPtr->tm_isdst) {
timeZone += 60;
}
return timeZone;
#endif
#if defined(HAVE_TIMEZONE_VAR) && !defined(TCL_GOT_TIMEZONE) && !defined(USE_DELTA_FOR_TZ)
# define TCL_GOT_TIMEZONE
int timeZone;
/* The 'timezone' external var is present and may be used. */
SetTZIfNecessary();
/*
* Note: this is not a typo in "timezone" below! See tzset
* documentation for details.
*/
timeZone = timezone / 60;
return timeZone;
#endif
#if !defined(TCL_GOT_TIMEZONE)
#define TCL_GOT_TIMEZONE 1
/*
* Fallback - determine time zone with a known reference time.
*/
int timeZone;
time_t tt;
struct tm *stm;
tt = 849268800L; /* 1996-11-29 12:00:00 GMT */
stm = TclpLocaltime((TclpTime_t) &tt); /* eg 1996-11-29 6:00:00 CST6CDT */
/* The calculation below assumes a max of +12 or -12 hours from GMT */
timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min);
if ( stm -> tm_isdst ) {
timeZone += 60;
}
return timeZone; /* eg +360 for CST6CDT */
#endif
#ifndef TCL_GOT_TIMEZONE
/*
* Cause compile error, we don't know how to get timezone.
*/
#error autoconf did not figure out how to determine the timezone.
#endif
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
*/
struct tm *
TclpGetDate(time, useGMT)
TclpTime_t time;
int useGMT;
{
| < < | | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 |
*/
struct tm *
TclpGetDate(time, useGMT)
TclpTime_t time;
int useGMT;
{
if (useGMT) {
return TclpGmtime(time);
} else {
return TclpLocaltime(time);
}
}
/*
*----------------------------------------------------------------------
*
* TclpStrftime --
|
| ︙ | ︙ | |||
336 337 338 339 340 341 342 |
setlocale(LC_TIME, "");
return strftime(s, maxsize, format, t);
}
/*
*----------------------------------------------------------------------
*
| | | | > > > | | < < | < | | > | > | > > > > > > > > > | | | | > > > | | < < < | | | | > | > | > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 |
setlocale(LC_TIME, "");
return strftime(s, maxsize, format, t);
}
/*
*----------------------------------------------------------------------
*
* TclpGmtime --
*
* Wrapper around the 'gmtime' library function to make it thread
* safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes gmtime or gmtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
struct tm *
TclpGmtime( tt )
TclpTime_t_CONST tt;
{
CONST time_t *timePtr = (CONST time_t *) tt;
/* Pointer to the number of seconds
* since the local system's epoch */
/*
* Get a thread-local buffer to hold the returned time.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey );
#ifdef HAVE_GMTIME_R
gmtime_r(timePtr, &( tsdPtr->gmtime_buf ));
#else
Tcl_MutexLock( &tmMutex );
memcpy( (VOID *) &( tsdPtr->gmtime_buf ),
(VOID *) gmtime( timePtr ),
sizeof( struct tm ) );
Tcl_MutexUnlock( &tmMutex );
#endif
return &( tsdPtr->gmtime_buf );
}
/*
* Forwarder for obsolete item in Stubs
*/
struct tm*
TclpGmtime_unix( timePtr )
TclpTime_t_CONST timePtr;
{
return TclpGmtime( timePtr );
}
/*
*----------------------------------------------------------------------
*
* TclpLocaltime --
*
* Wrapper around the 'localtime' library function to make it thread
* safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes localtime or localtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
struct tm *
TclpLocaltime( tt )
TclpTime_t_CONST tt;
{
CONST time_t *timePtr = (CONST time_t *) tt;
/* Pointer to the number of seconds
* since the local system's epoch */
/*
* Get a thread-local buffer to hold the returned time.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT( &tmKey );
SetTZIfNecessary();
#ifdef HAVE_LOCALTIME_R
localtime_r( timePtr, &( tsdPtr->localtime_buf ) );
#else
Tcl_MutexLock( &tmMutex );
memcpy( (VOID *) &( tsdPtr -> localtime_buf ),
(VOID *) localtime( timePtr ),
sizeof( struct tm ) );
Tcl_MutexUnlock( &tmMutex );
#endif
return &( tsdPtr->localtime_buf );
}
/*
* Forwarder for obsolete item in Stubs
*/
struct tm*
TclpLocaltime_unix( timePtr )
TclpTime_t_CONST timePtr;
{
return TclpLocaltime( timePtr );
}
/*
*----------------------------------------------------------------------
*
* SetTZIfNecessary --
*
* Determines whether a call to 'tzset' is needed prior to the
* next call to 'localtime' or examination of the 'timezone' variable.
*
* Results:
* None.
*
* Side effects:
* If 'tzset' has never been called in the current process, or if
* the value of the environment variable TZ has changed since the
* last call to 'tzset', then 'tzset' is called again.
*
*----------------------------------------------------------------------
*/
static void
SetTZIfNecessary() {
CONST char* newTZ = getenv( "TZ" );
Tcl_MutexLock(&tmMutex);
if ( newTZ == NULL ) {
newTZ = "";
}
if ( lastTZ == NULL || strcmp( lastTZ, newTZ ) ) {
tzset();
if ( lastTZ == NULL ) {
Tcl_CreateExitHandler( CleanupMemory, (ClientData) NULL );
} else {
Tcl_Free( lastTZ );
}
lastTZ = ckalloc( strlen( newTZ ) + 1 );
strcpy( lastTZ, newTZ );
}
Tcl_MutexUnlock(&tmMutex);
}
/*
*----------------------------------------------------------------------
*
* CleanupMemory --
*
* Releases the private copy of the TZ environment variable
* upon exit from Tcl.
*
* Results:
* None.
*
* Side effects:
* Frees allocated memory.
*
*----------------------------------------------------------------------
*/
static void
CleanupMemory( ClientData ignored )
{
ckfree( lastTZ );
}
|
Changes to win/Makefile.in.
1 2 3 4 5 6 7 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # # This file is a Makefile for Tcl. If it has the name "Makefile.in" # then it is a template for a Makefile; to generate the actual Makefile, # run "./configure", which is a configuration script generated by the # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # # RCS: @(#) $Id: Makefile.in,v 1.68.2.7 2007/01/30 23:21:12 hobbs Exp $ VERSION = @TCL_VERSION@ #---------------------------------------------------------------- # Things you can change to personalize the Makefile for your own # site (you can make these changes in either Makefile.in or # Makefile, but changes to Makefile will get lost if you re-run |
| ︙ | ︙ | |||
52 53 54 55 56 57 58 59 60 61 62 63 64 65 | # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library | > > > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Top-level directory in which to install manual entries: MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) # Directory in which to install manual entry for tclsh: MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 # Directory in which to install manual entries for Tcl's C library |
| ︙ | ︙ | |||
81 82 83 84 85 86 87 | CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) | | | | | | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ # To change the compiler switches, for example to change from optimization to # debugging symbols, change the following line: #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ # To enable compilation debugging reverse the comment characters on # one of the following lines. COMPILE_DEBUG_FLAGS = #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS # Special compiler flags to use when building man2tcl on Windows. MAN2TCLFLAGS = @MAN2TCLFLAGS@ SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. GENERIC_DIR = @srcdir@/../generic WIN_DIR = @srcdir@ COMPAT_DIR = @srcdir@/../compat # Converts a POSIX path to a Windows native path. CYGPATH = @CYGPATH@ GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)' | sed 's!\\!/!g') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)' | sed 's!\\!/!g') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)' | sed 's!\\!/!g') LIBRARY_DIR = $(ROOT_DIR_NATIVE)/library DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ EXESUFFIX = @EXESUFFIX@ TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_DLL_FILE = @TCL_DLL_FILE@ |
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
$(CC) $(CFLAGS) $(TCLTEST_OBJS) $(TCL_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
$(CAT32): cat32.$(OBJEXT)
| | | 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 |
$(CC) $(CFLAGS) $(TCLTEST_OBJS) $(TCL_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
$(CAT32): cat32.$(OBJEXT)
$(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE)
# The following targets are configured by autoconf to generate either
# a shared library or static library
${TCL_STUB_LIB_FILE}: ${STUB_OBJS}
@$(RM) ${TCL_STUB_LIB_FILE}
@MAKE_LIB@ ${STUB_OBJS}
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
.SUFFIXES: .rc
# Special case object targets
tclWinInit.${OBJEXT}: tclWinInit.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
testMain.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME)
tclTest.${OBJEXT}: tclTest.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
tclTestObj.${OBJEXT}: tclTestObj.c
| > > > > | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 |
.SUFFIXES: .rc
# Special case object targets
tclWinInit.${OBJEXT}: tclWinInit.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinPipe.${OBJEXT}: tclWinPipe.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_PIPE_DLL=\"$(PIPE_DLL_FILE)\" \
$(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
testMain.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME)
tclTest.${OBJEXT}: tclTest.c
$(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME)
tclTestObj.${OBJEXT}: tclTestObj.c
|
| ︙ | ︙ | |||
482 483 484 485 486 487 488 | do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ $(MKDIR) $$i; \ else true; \ fi; \ done; | | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 | do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ $(MKDIR) $$i; \ else true; \ fi; \ done; @for i in http1.0 http2.5 opt0.4 encoding msgcat1.3 tcltest2.2; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ $(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \ else true; \ fi; \ done; |
| ︙ | ︙ | |||
506 507 508 509 510 511 512 | $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing library http1.0 directory"; @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; | | | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 | $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing library http1.0 directory"; @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; @echo "Installing library http2.5 directory"; @for j in $(ROOT_DIR)/library/http/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http2.5"; \ done; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; @echo "Installing library msgcat1.3 directory"; |
| ︙ | ︙ | |||
532 533 534 535 536 537 538 539 540 541 542 543 544 545 | done; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ done; install-doc: doc # Specifying TESTFLAGS on the command line is the standard way to pass # args to tcltest, ie: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: binaries $(TCLTEST) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ | > > > > > > > > > > > > > > > > > > > | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 | done; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ done; install-doc: doc # Optional target to install private headers install-private-headers: libraries @for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ $(MKDIR) $$i; \ chmod 755 $$i; \ else true; \ fi; \ done; @echo "Installing private header files to $(PRIVATE_INCLUDE_INSTALL_DIR)/"; @for i in "$(GENERIC_DIR)/tclInt.h" "$(GENERIC_DIR)/tclIntDecls.h" \ "$(GENERIC_DIR)/tclIntPlatDecls.h" "$(GENERIC_DIR)/tclPort.h" \ "$(WIN_DIR)/tclWinPort.h" ; \ do \ $(COPY) "$$i" "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ done; # Specifying TESTFLAGS on the command line is the standard way to pass # args to tcltest, ie: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: binaries $(TCLTEST) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ |
| ︙ | ︙ |
Changes to win/README.
1 2 | Tcl 8.4 for Windows | | | 1 2 3 4 5 6 7 8 9 10 | Tcl 8.4 for Windows RCS: @(#) $Id: README,v 1.30.2.1 2005/07/29 03:50:51 mdejong Exp $ 1. Introduction --------------- This is the directory where you configure and compile the Windows version of Tcl. This directory also contains source files for Tcl that are specific to Microsoft Windows. |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | Visual C++ 5 or newer or Msys + Mingw | | < < < < < < < < < < < | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | Visual C++ 5 or newer or Msys + Mingw http://prdownloads.sourceforge.net/tcl/msys_mingw8.zip This Msys + Mingw download is the minimal environment needed to build Tcl/Tk under Windows. It includes a shell environment and gcc. The release is designed to make it as easy a possible to build Tcl/Tk. To install, you just download the zip file and extract the files into a directory. The README.TXT file describes how to launch the msys shell, you then run the configure script in the tcl/win directory. In practice, this release is built with Visual C++ 6.0 and the TEA Makefile. If you are building with Visual C++, in the "win" subdirectory of the source release, you will find "makefile.vc". This is the makefile for the Visual C++ compiler and uses the stock NMAKE tool. Detailed |
| ︙ | ︙ |
Changes to win/README.binary.
1 2 | Tcl/Tk 8.4 for Windows, Binary Distribution | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | Tcl/Tk 8.4 for Windows, Binary Distribution RCS: @(#) $Id: README.binary,v 1.33.2.16 2007/05/30 14:05:21 dgp Exp $ 1. Introduction --------------- This directory contains the binary distribution of Tcl/Tk 8.4.16 for Windows. It was compiled with Microsoft Visual C++ 6.0 using Win32 API, so that it will run under Windows NT, 95, 98 and 2000. Tcl provides a powerful platform for creating integration applications that tie together diverse applications, protocols, devices, and frameworks. When paired with the Tk toolkit, Tcl provides the fastest and most powerful way to create GUI applications that run on PCs, Unix, |
| ︙ | ︙ |
Changes to win/coffbase.txt.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | ; relocations (NT supported only). It is assumed extension authors will contribute ; their modules to this grand-master list. You can use the dumpbin utility with ; the /headers option to get the "size of image" data (already in hex). If the ; maximum size is too small a linker warning will occur. Modules can overlap when ; they're mutually exclusive. This info is placed in the DLL's PE header by the ; linker with the `-base:@$(TCLDIR)\win\coffbase.txt,<key>` option. ; | | > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | ; relocations (NT supported only). It is assumed extension authors will contribute ; their modules to this grand-master list. You can use the dumpbin utility with ; the /headers option to get the "size of image" data (already in hex). If the ; maximum size is too small a linker warning will occur. Modules can overlap when ; they're mutually exclusive. This info is placed in the DLL's PE header by the ; linker with the `-base:@$(TCLDIR)\win\coffbase.txt,<key>` option. ; ; RCS: @(#) $Id: coffbase.txt,v 1.5.2.1 2004/05/06 01:03:33 davygrvy Exp $ tcl 0x10000000 0x00200000 tcldde 0x10200000 0x00010000 tclreg 0x10210000 0x00010000 tk 0x10220000 0x00200000 expect 0x10480000 0x00080000 itcl 0x10500000 0x00080000 itk 0x10580000 0x00080000 bltlite 0x10600000 0x00080000 blt 0x10680000 0x00080000 iocpsock 0x10700000 0x00080000 tls 0x10780000 0x00080000 |
Changes to win/configure.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | ac_default_prefix=/usr/local # Any additions from configure.in: ac_help="$ac_help --enable-threads build with threads" ac_help="$ac_help --enable-shared build and link with shared libraries [--enable-shared]" ac_help="$ac_help | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | ac_default_prefix=/usr/local # Any additions from configure.in: ac_help="$ac_help --enable-threads build with threads" ac_help="$ac_help --enable-shared build and link with shared libraries [--enable-shared]" ac_help="$ac_help --enable-64bit enable 64bit support (where applicable = amd64|ia64)" ac_help="$ac_help --enable-symbols build with debugging symbols [--disable-symbols]" # Initialize some variables set by options. # The variables have the same names as the options, with # dashes changed to underlines. build=NONE |
| ︙ | ︙ | |||
530 531 532 533 534 535 536 | TCL_VERSION=8.4 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=4 | | < < | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 |
TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL=".16"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.2
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=2
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
TCL_REG_VERSION=1.1
TCL_REG_MAJOR_VERSION=1
TCL_REG_MINOR_VERSION=1
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
if test "${prefix}" = "NONE"; then
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
| | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
if test "${CFLAGS+set}" != "set" ; then
CFLAGS=""
fi
# Extract the first word of "gcc", so it can be a program name with args.
set dummy gcc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:577: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
|
| ︙ | ︙ | |||
601 602 603 604 605 606 607 | echo "$ac_t""no" 1>&6 fi if test -z "$CC"; then # Extract the first word of "cc", so it can be a program name with args. set dummy cc; ac_word=$2 echo $ac_n "checking for $ac_word""... $ac_c" 1>&6 | | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
echo "$ac_t""no" 1>&6
fi
if test -z "$CC"; then
# Extract the first word of "cc", so it can be a program name with args.
set dummy cc; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:607: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
|
| ︙ | ︙ | |||
652 653 654 655 656 657 658 |
if test -z "$CC"; then
case "`uname -s`" in
*win32* | *WIN32*)
# Extract the first word of "cl", so it can be a program name with args.
set dummy cl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
| | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
if test -z "$CC"; then
case "`uname -s`" in
*win32* | *WIN32*)
# Extract the first word of "cl", so it can be a program name with args.
set dummy cl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:658: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test -n "$CC"; then
ac_cv_prog_CC="$CC" # Let the user override the test.
else
IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
|
| ︙ | ︙ | |||
684 685 686 687 688 689 690 |
;;
esac
fi
test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
| | | | | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
;;
esac
fi
test -z "$CC" && { echo "configure: error: no acceptable cc found in \$PATH" 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works""... $ac_c" 1>&6
echo "configure:690: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) works" >&5
ac_ext=c
# CFLAGS is not in ac_cpp because -g, -O, etc. are not valid cpp options.
ac_cpp='$CPP $CPPFLAGS'
ac_compile='${CC-cc} -c $CFLAGS $CPPFLAGS conftest.$ac_ext 1>&5'
ac_link='${CC-cc} -o conftest${ac_exeext} $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS 1>&5'
cross_compiling=$ac_cv_prog_cc_cross
cat > conftest.$ac_ext << EOF
#line 701 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
if { (eval echo configure:706: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
ac_cv_prog_cc_works=yes
# If we can't run a trivial program, we are probably using a cross compiler.
if (./conftest; exit) 2>/dev/null; then
ac_cv_prog_cc_cross=no
else
ac_cv_prog_cc_cross=yes
fi
|
| ︙ | ︙ | |||
726 727 728 729 730 731 732 |
cross_compiling=$ac_cv_prog_cc_cross
echo "$ac_t""$ac_cv_prog_cc_works" 1>&6
if test $ac_cv_prog_cc_works = no; then
{ echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
| | | | | | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
cross_compiling=$ac_cv_prog_cc_cross
echo "$ac_t""$ac_cv_prog_cc_works" 1>&6
if test $ac_cv_prog_cc_works = no; then
{ echo "configure: error: installation or configuration problem: C compiler cannot create executables." 1>&2; exit 1; }
fi
echo $ac_n "checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler""... $ac_c" 1>&6
echo "configure:732: checking whether the C compiler ($CC $CFLAGS $LDFLAGS) is a cross-compiler" >&5
echo "$ac_t""$ac_cv_prog_cc_cross" 1>&6
cross_compiling=$ac_cv_prog_cc_cross
echo $ac_n "checking whether we are using GNU C""... $ac_c" 1>&6
echo "configure:737: checking whether we are using GNU C" >&5
if eval "test \"`echo '$''{'ac_cv_prog_gcc'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.c <<EOF
#ifdef __GNUC__
yes;
#endif
EOF
if { ac_try='${CC-cc} -E conftest.c'; { (eval echo configure:746: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } | egrep yes >/dev/null 2>&1; then
ac_cv_prog_gcc=yes
else
ac_cv_prog_gcc=no
fi
fi
echo "$ac_t""$ac_cv_prog_gcc" 1>&6
if test $ac_cv_prog_gcc = yes; then
GCC=yes
else
GCC=
fi
ac_test_CFLAGS="${CFLAGS+set}"
ac_save_CFLAGS="$CFLAGS"
CFLAGS=
echo $ac_n "checking whether ${CC-cc} accepts -g""... $ac_c" 1>&6
echo "configure:765: checking whether ${CC-cc} accepts -g" >&5
if eval "test \"`echo '$''{'ac_cv_prog_cc_g'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
echo 'void f(){}' > conftest.c
if test -z "`${CC-cc} -g -c conftest.c 2>&1`"; then
ac_cv_prog_cc_g=yes
else
|
| ︙ | ︙ | |||
802 803 804 805 806 807 808 |
# the CC, AR, RANLIB, and RC environment
# variables if you want to cross compile.
if test "${GCC}" = "yes" ; then
# Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
| | | 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 |
# the CC, AR, RANLIB, and RC environment
# variables if you want to cross compile.
if test "${GCC}" = "yes" ; then
# Extract the first word of "ar", so it can be a program name with args.
set dummy ar; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:808: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_AR'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test -n "$AR"; then
ac_cv_prog_AR="$AR" # Let the user override the test.
else
IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
else
echo "$ac_t""no" 1>&6
fi
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
| | | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 |
else
echo "$ac_t""no" 1>&6
fi
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:837: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test -n "$RANLIB"; then
ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test.
else
IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 |
else
echo "$ac_t""no" 1>&6
fi
# Extract the first word of "windres", so it can be a program name with args.
set dummy windres; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
| | | 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 |
else
echo "$ac_t""no" 1>&6
fi
# Extract the first word of "windres", so it can be a program name with args.
set dummy windres; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:866: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RC'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test -n "$RC"; then
ac_cv_prog_RC="$RC" # Let the user override the test.
else
IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
|
| ︙ | ︙ | |||
903 904 905 906 907 908 909 |
fi
#--------------------------------------------------------------------
# Checks to see if the make progeam sets the $MAKE variable.
#--------------------------------------------------------------------
echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
| | | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 |
fi
#--------------------------------------------------------------------
# Checks to see if the make progeam sets the $MAKE variable.
#--------------------------------------------------------------------
echo $ac_n "checking whether ${MAKE-make} sets \${MAKE}""... $ac_c" 1>&6
echo "configure:909: checking whether ${MAKE-make} sets \${MAKE}" >&5
set dummy ${MAKE-make}; ac_make=`echo "$2" | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_prog_make_${ac_make}_set'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftestmake <<\EOF
all:
@echo 'ac_maketemp="${MAKE}"'
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 | #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- echo $ac_n "checking for Cygwin environment""... $ac_c" 1>&6 | | | | | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 |
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
echo $ac_n "checking for Cygwin environment""... $ac_c" 1>&6
echo "configure:941: checking for Cygwin environment" >&5
if eval "test \"`echo '$''{'ac_cv_cygwin'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 946 "configure"
#include "confdefs.h"
int main() {
#ifndef __CYGWIN__
#define __CYGWIN__ __CYGWIN32__
#endif
return __CYGWIN__;
; return 0; }
EOF
if { (eval echo configure:957: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_cygwin=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_cygwin=no
|
| ︙ | ︙ | |||
976 977 978 979 980 981 982 |
{ echo "configure: error: Compiling under Cygwin is not currently supported.
A maintainer for the Cygwin port of Tcl/Tk is needed. See the README
file for information about building with Mingw." 1>&2; exit 1; }
fi
echo $ac_n "checking for SEH support in compiler""... $ac_c" 1>&6
| | | | | 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
{ echo "configure: error: Compiling under Cygwin is not currently supported.
A maintainer for the Cygwin port of Tcl/Tk is needed. See the README
file for information about building with Mingw." 1>&2; exit 1; }
fi
echo $ac_n "checking for SEH support in compiler""... $ac_c" 1>&6
echo "configure:982: checking for SEH support in compiler" >&5
if eval "test \"`echo '$''{'tcl_cv_seh'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test "$cross_compiling" = yes; then
tcl_cv_seh=no
else
cat > conftest.$ac_ext <<EOF
#line 990 "configure"
#include "confdefs.h"
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
int main(int argc, char** argv) {
int a, b = 0;
__try {
a = 666 / b;
}
__except (EXCEPTION_EXECUTE_HANDLER) {
return 0;
}
return 1;
}
EOF
if { (eval echo configure:1009: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_cv_seh=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_cv_seh=no
|
| ︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 | # # Check to see if the excpt.h include file provided contains the # definition for EXCEPTION_DISPOSITION; if not, which is the case # with Cygwin's version as of 2002-04-10, define it to be int, # sufficient for getting the current code to work. # echo $ac_n "checking for EXCEPTION_DISPOSITION support in include files""... $ac_c" 1>&6 | | | | | 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 |
#
# Check to see if the excpt.h include file provided contains the
# definition for EXCEPTION_DISPOSITION; if not, which is the case
# with Cygwin's version as of 2002-04-10, define it to be int,
# sufficient for getting the current code to work.
#
echo $ac_n "checking for EXCEPTION_DISPOSITION support in include files""... $ac_c" 1>&6
echo "configure:1039: checking for EXCEPTION_DISPOSITION support in include files" >&5
if eval "test \"`echo '$''{'tcl_cv_eh_disposition'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1044 "configure"
#include "confdefs.h"
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
int main() {
EXCEPTION_DISPOSITION x;
; return 0; }
EOF
if { (eval echo configure:1057: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_eh_disposition=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_eh_disposition=no
|
| ︙ | ︙ | |||
1077 1078 1079 1080 1081 1082 1083 | fi # Check to see if the winsock2.h include file provided contains # typedefs like LPFN_ACCEPT and friends. # echo $ac_n "checking for LPFN_ACCEPT support in winsock2.h""... $ac_c" 1>&6 | | | | | 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 |
fi
# Check to see if the winsock2.h include file provided contains
# typedefs like LPFN_ACCEPT and friends.
#
echo $ac_n "checking for LPFN_ACCEPT support in winsock2.h""... $ac_c" 1>&6
echo "configure:1083: checking for LPFN_ACCEPT support in winsock2.h" >&5
if eval "test \"`echo '$''{'tcl_cv_lpfn_decls'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1088 "configure"
#include "confdefs.h"
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
#include <winsock2.h>
int main() {
LPFN_ACCEPT accept;
; return 0; }
EOF
if { (eval echo configure:1102: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_lpfn_decls=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_lpfn_decls=no
|
| ︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 | fi # Check to see if winnt.h defines CHAR, SHORT, and LONG # even if VOID has already been #defined. The win32api # used by mingw and cygwin is known to do this. echo $ac_n "checking for winnt.h that ignores VOID define""... $ac_c" 1>&6 | | | | | 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 |
fi
# Check to see if winnt.h defines CHAR, SHORT, and LONG
# even if VOID has already been #defined. The win32api
# used by mingw and cygwin is known to do this.
echo $ac_n "checking for winnt.h that ignores VOID define""... $ac_c" 1>&6
echo "configure:1128: checking for winnt.h that ignores VOID define" >&5
if eval "test \"`echo '$''{'tcl_cv_winnt_ignore_void'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1133 "configure"
#include "confdefs.h"
#define VOID void
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#undef WIN32_LEAN_AND_MEAN
int main() {
CHAR c;
SHORT s;
LONG l;
; return 0; }
EOF
if { (eval echo configure:1149: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_winnt_ignore_void=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_winnt_ignore_void=no
|
| ︙ | ︙ | |||
1175 1176 1177 1178 1179 1180 1181 | # If we add the function declaration ourselves, it # would not compile correctly because the _alloca # function expects the argument to be passed in a # register and not on the stack. Instead, we just # call it from inline asm code. echo $ac_n "checking for alloca declaration in malloc.h""... $ac_c" 1>&6 | | | | | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 |
# If we add the function declaration ourselves, it
# would not compile correctly because the _alloca
# function expects the argument to be passed in a
# register and not on the stack. Instead, we just
# call it from inline asm code.
echo $ac_n "checking for alloca declaration in malloc.h""... $ac_c" 1>&6
echo "configure:1181: checking for alloca declaration in malloc.h" >&5
if eval "test \"`echo '$''{'tcl_cv_malloc_decl_alloca'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1186 "configure"
#include "confdefs.h"
#include <malloc.h>
int main() {
size_t arg = 0;
void* ptr;
ptr = alloca;
ptr = alloca(arg);
; return 0; }
EOF
if { (eval echo configure:1200: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_malloc_decl_alloca=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_malloc_decl_alloca=no
|
| ︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 | fi # See if the compiler supports casting to a union type. # This is used to stop gcc from printing a compiler # warning when initializing a union member. echo $ac_n "checking for cast to union support""... $ac_c" 1>&6 | | | | | 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 |
fi
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
echo $ac_n "checking for cast to union support""... $ac_c" 1>&6
echo "configure:1227: checking for cast to union support" >&5
if eval "test \"`echo '$''{'tcl_cv_cast_to_union'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1232 "configure"
#include "confdefs.h"
int main() {
union foo { int i; double d; };
union foo f = (union foo) (int) 0;
; return 0; }
EOF
if { (eval echo configure:1242: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_cast_to_union=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_cast_to_union=no
|
| ︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 | #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- echo $ac_n "checking for object suffix""... $ac_c" 1>&6 | | | | | | | | | 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 |
#--------------------------------------------------------------------
# Determines the correct binary file extension (.o, .obj, .exe etc.)
#--------------------------------------------------------------------
echo $ac_n "checking for object suffix""... $ac_c" 1>&6
echo "configure:1269: checking for object suffix" >&5
if eval "test \"`echo '$''{'ac_cv_objext'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
rm -f conftest*
echo 'int i = 1;' > conftest.$ac_ext
if { (eval echo configure:1275: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
for ac_file in conftest.*; do
case $ac_file in
*.c) ;;
*) ac_cv_objext=`echo $ac_file | sed -e s/conftest.//` ;;
esac
done
else
{ echo "configure: error: installation or configuration problem; compiler does not work" 1>&2; exit 1; }
fi
rm -f conftest*
fi
echo "$ac_t""$ac_cv_objext" 1>&6
OBJEXT=$ac_cv_objext
ac_objext=$ac_cv_objext
echo $ac_n "checking for mingw32 environment""... $ac_c" 1>&6
echo "configure:1293: checking for mingw32 environment" >&5
if eval "test \"`echo '$''{'ac_cv_mingw32'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1298 "configure"
#include "confdefs.h"
int main() {
return __MINGW32__;
; return 0; }
EOF
if { (eval echo configure:1305: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_mingw32=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_mingw32=no
fi
rm -f conftest*
rm -f conftest*
fi
echo "$ac_t""$ac_cv_mingw32" 1>&6
MINGW32=
test "$ac_cv_mingw32" = yes && MINGW32=yes
echo $ac_n "checking for executable suffix""... $ac_c" 1>&6
echo "configure:1324: checking for executable suffix" >&5
if eval "test \"`echo '$''{'ac_cv_exeext'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test "$CYGWIN" = yes || test "$MINGW32" = yes; then
ac_cv_exeext=.exe
else
rm -f conftest*
echo 'int main () { return 0; }' > conftest.$ac_ext
ac_cv_exeext=
if { (eval echo configure:1334: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; }; then
for file in conftest.*; do
case $file in
*.c | *.o | *.obj) ;;
*) ac_cv_exeext=`echo $file | sed -e s/conftest//` ;;
esac
done
else
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 |
#--------------------------------------------------------------------
# Check whether --enable-threads or --disable-threads was given.
#--------------------------------------------------------------------
echo $ac_n "checking for building with threads""... $ac_c" 1>&6
| | | 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 |
#--------------------------------------------------------------------
# Check whether --enable-threads or --disable-threads was given.
#--------------------------------------------------------------------
echo $ac_n "checking for building with threads""... $ac_c" 1>&6
echo "configure:1361: checking for building with threads" >&5
# Check whether --enable-threads or --disable-threads was given.
if test "${enable_threads+set}" = set; then
enableval="$enable_threads"
tcl_ok=$enableval
else
tcl_ok=no
fi
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 |
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------
echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
| | | 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 |
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------
echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
echo "configure:1398: checking how to build libraries" >&5
# Check whether --enable-shared or --disable-shared was given.
if test "${enable_shared+set}" = set; then
enableval="$enable_shared"
tcl_ok=$enableval
else
tcl_ok=yes
fi
|
| ︙ | ︙ | |||
1433 1434 1435 1436 1437 1438 1439 |
#--------------------------------------------------------------------
# Step 0: Enable 64 bit support?
echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
| | | | 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 |
#--------------------------------------------------------------------
# Step 0: Enable 64 bit support?
echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
echo "configure:1439: checking if 64bit support is requested" >&5
# Check whether --enable-64bit or --disable-64bit was given.
if test "${enable_64bit+set}" = set; then
enableval="$enable_64bit"
do64bit=$enableval
else
do64bit=no
fi
echo "$ac_t""$do64bit" 1>&6
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
# Extract the first word of "cygpath", so it can be a program name with args.
set dummy cygpath; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:1456: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_CYGPATH'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test -n "$CYGPATH"; then
ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test.
else
IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS=":"
|
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 |
echo "$ac_t""$CYGPATH" 1>&6
else
echo "$ac_t""no" 1>&6
fi
SHLIB_SUFFIX=".dll"
# Check for a bug in gcc's windres that causes the
# compile to fail when a Windows native path is
# passed into windres. The mingw toolchain requires
# Windows native paths while Cygwin should work
# with both. Avoid the bug by passing a POSIX
# path when using the Cygwin toolchain.
if test "$GCC" = "yes" && test "$CYGPATH" != "echo" ; then
conftest=/tmp/conftest.rc
echo "STRINGTABLE BEGIN" > $conftest
echo "101 \"name\"" >> $conftest
echo "END" >> $conftest
echo $ac_n "checking for Windows native path bug in windres""... $ac_c" 1>&6
| > > > > | | | | | 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 |
echo "$ac_t""$CYGPATH" 1>&6
else
echo "$ac_t""no" 1>&6
fi
SHLIB_SUFFIX=".dll"
# MACHINE is IX86 for LINK, but this is used by the manifest,
# which requires x86|amd64|ia64.
MACHINE="X86"
# Check for a bug in gcc's windres that causes the
# compile to fail when a Windows native path is
# passed into windres. The mingw toolchain requires
# Windows native paths while Cygwin should work
# with both. Avoid the bug by passing a POSIX
# path when using the Cygwin toolchain.
if test "$GCC" = "yes" && test "$CYGPATH" != "echo" ; then
conftest=/tmp/conftest.rc
echo "STRINGTABLE BEGIN" > $conftest
echo "101 \"name\"" >> $conftest
echo "END" >> $conftest
echo $ac_n "checking for Windows native path bug in windres""... $ac_c" 1>&6
echo "configure:1504: checking for Windows native path bug in windres" >&5
cyg_conftest=`$CYGPATH $conftest`
if { ac_try='$RC -o conftest.res.o $cyg_conftest'; { (eval echo configure:1506: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }; } ; then
echo "$ac_t""no" 1>&6
else
echo "$ac_t""yes" 1>&6
CYGPATH=echo
fi
conftest=
cyg_conftest=
fi
if test "$CYGPATH" = "echo" || test "$ac_cv_cygwin" = "yes"; then
DEPARG='"$<"'
else
DEPARG='"$(shell $(CYGPATH) $<)"'
fi
# set various compiler flags depending on whether we are using gcc or cl
echo $ac_n "checking compiler flags""... $ac_c" 1>&6
echo "configure:1525: checking compiler flags" >&5
if test "${GCC}" = "yes" ; then
if test "$do64bit" != "no" ; then
echo "configure: warning: "64bit mode not supported with GCC on Windows"" 1>&2
fi
SHLIB_LD=""
SHLIB_LD_LIBS=""
LIBS=""
LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32"
STLIB_LD='${AR} cr'
|
| ︙ | ︙ | |||
1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 |
if test "${SHARED_BUILD}" = "0" ; then
# static
echo "$ac_t""using static flags" 1>&6
runtime=
MAKE_DLL="echo "
LIBSUFFIX="s\${DBGX}.a"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
else
# dynamic
echo "$ac_t""using shared flags" 1>&6
# ad-hoc check to see if CC supports -shared.
| > | 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 |
if test "${SHARED_BUILD}" = "0" ; then
# static
echo "$ac_t""using static flags" 1>&6
runtime=
MAKE_DLL="echo "
LIBSUFFIX="s\${DBGX}.a"
LIBFLAGSUFFIX="s\${DBGX}"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
else
# dynamic
echo "$ac_t""using shared flags" 1>&6
# ad-hoc check to see if CC supports -shared.
|
| ︙ | ︙ | |||
1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 |
SHLIB_LD='${CC} -shared ${CFLAGS}'
SHLIB_LD_LIBS='${LIBS}'
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)"
LIBSUFFIX="\${DBGX}.a"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
| > | | 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 |
SHLIB_LD='${CC} -shared ${CFLAGS}'
SHLIB_LD_LIBS='${LIBS}'
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)"
LIBSUFFIX="\${DBGX}.a"
LIBFLAGSUFFIX="\${DBGX}"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wconversion"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
# Specify the CC output file names based on the target name
CC_OBJNAME="-o \$@"
CC_EXENAME="-o \$@"
|
| ︙ | ︙ | |||
1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 |
else
if test "${SHARED_BUILD}" = "0" ; then
# static
echo "$ac_t""using static flags" 1>&6
runtime=-MT
MAKE_DLL="echo "
LIBSUFFIX="s\${DBGX}.lib"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
SHLIB_LD_LIBS=""
else
# dynamic
echo "$ac_t""using shared flags" 1>&6
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
LIBSUFFIX="\${DBGX}.lib"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
SHLIB_LD_LIBS='${LIBS}'
fi
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
# This is a 2-stage check to make sure we have the 64-bit SDK
# We have to know where the SDK is installed.
| > > > | | < < | > > > > > > > > > > > | > | > > > > > | < < < < | < | | > | < | < | > > > > > > | | | > < < > > > | | | 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 |
else
if test "${SHARED_BUILD}" = "0" ; then
# static
echo "$ac_t""using static flags" 1>&6
runtime=-MT
MAKE_DLL="echo "
LIBSUFFIX="s\${DBGX}.lib"
LIBFLAGSUFFIX="s\${DBGX}"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
SHLIB_LD_LIBS=""
else
# dynamic
echo "$ac_t""using shared flags" 1>&6
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
LIBSUFFIX="\${DBGX}.lib"
LIBFLAGSUFFIX="\${DBGX}"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
SHLIB_LD_LIBS='${LIBS}'
fi
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
# This is a 2-stage check to make sure we have the 64-bit SDK
# We have to know where the SDK is installed.
# This magic is based on MS Platform SDK for Win2003 SP1 - hobbs
if test "$do64bit" != "no" ; then
if test "x${MSSDK}x" = "xx" ; then
MSSDK="C:/Progra~1/Microsoft Platform SDK"
fi
MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'`
PATH64=""
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # default to AMD64 64-bit build
PATH64="${MSSDK}/Bin/Win64/x86/AMD64"
;;
ia64)
MACHINE="IA64"
PATH64="${MSSDK}/Bin/Win64"
;;
esac
if test ! -d "${PATH64}" ; then
echo "configure: warning: Could not find 64-bit $MACHINE SDK to enable 64bit mode" 1>&2
echo "configure: warning: Ensure latest Platform SDK is installed" 1>&2
do64bit="no"
else
echo "$ac_t"" Using 64-bit $MACHINE mode" 1>&6
fi
fi
if test "$do64bit" != "no" ; then
# The space-based-path will work for the Makefile, but will
# not work if AC_TRY_COMPILE is called.
CC="\"${PATH64}/cl.exe\" -I\"${MSSDK}/Include\" \
-I\"${MSSDK}/Include/crt\" -I\"${MSSDK}/Include/crt/sys\""
RC="\"${MSSDK}/bin/rc.exe\""
CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"
# Do not use -O2 for Win64 - this has proved buggy in code gen.
CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}"
lflags="-nologo -MACHINE:${MACHINE} -LIBPATH:\"${MSSDK}/Lib/${MACHINE}\""
LINKBIN="\"${PATH64}/link.exe\""
# Avoid 'unresolved external symbol __security_cookie' errors.
# c.f. http://support.microsoft.com/?id=894573
LIBS="user32.lib advapi32.lib bufferoverflowU.lib"
else
RC="rc"
# -Od - no optimization
# -WX - warnings as errors
CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
# -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy)
CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}"
lflags="-nologo"
LINKBIN="link"
LIBS="user32.lib advapi32.lib"
fi
LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib"
SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
# link -lib only works when -lib is the first arg
STLIB_LD="${LINKBIN} -lib ${lflags}"
RC_OUT=-fo
RC_TYPE=-r
RC_INCLUDE=-i
RC_DEFINE=-d
RES=res
MAKE_LIB="\${STLIB_LD} -out:\$@"
POST_MAKE_LIB=
MAKE_EXE="\${CC} -Fe\$@"
LIBPREFIX=""
EXTRA_CFLAGS=""
CFLAGS_WARNING="-W3"
LDFLAGS_DEBUG="-debug:full"
LDFLAGS_OPTIMIZE="-release"
# Specify the CC output file names based on the target name
CC_OBJNAME="-Fo\$@"
CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\""
# Specify linker flags depending on the type of app being
|
| ︙ | ︙ | |||
1731 1732 1733 1734 1735 1736 1737 |
# Set the default compiler switches based on the --enable-symbols
# option. This macro depends on C flags, and should be called
# after SC_CONFIG_CFLAGS macro is called.
#--------------------------------------------------------------------
echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
| | | 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 |
# Set the default compiler switches based on the --enable-symbols
# option. This macro depends on C flags, and should be called
# after SC_CONFIG_CFLAGS macro is called.
#--------------------------------------------------------------------
echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
echo "configure:1763: checking for build with symbols" >&5
# Check whether --enable-symbols or --disable-symbols was given.
if test "${enable_symbols+set}" = set; then
enableval="$enable_symbols"
tcl_ok=$enableval
else
tcl_ok=no
fi
|
| ︙ | ︙ | |||
1791 1792 1793 1794 1795 1796 1797 |
TCL_DBGX=${DBGX}
#--------------------------------------------------------------------
# man2tcl needs this so that it can use errno.h
#--------------------------------------------------------------------
echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
| | | | | | | | | 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 |
TCL_DBGX=${DBGX}
#--------------------------------------------------------------------
# man2tcl needs this so that it can use errno.h
#--------------------------------------------------------------------
echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
echo "configure:1823: checking how to run the C preprocessor" >&5
# On Suns, sometimes $CPP names a directory.
if test -n "$CPP" && test -d "$CPP"; then
CPP=
fi
if test -z "$CPP"; then
if eval "test \"`echo '$''{'ac_cv_prog_CPP'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
# This must be in double quotes, not single quotes, because CPP may get
# substituted into the Makefile and "${CC-cc}" will confuse make.
CPP="${CC-cc} -E"
# On the NeXT, cc -E runs the code through the compiler's parser,
# not just through cpp.
cat > conftest.$ac_ext <<EOF
#line 1838 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1844: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
else
echo "$ac_err" >&5
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
CPP="${CC-cc} -E -traditional-cpp"
cat > conftest.$ac_ext <<EOF
#line 1855 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1861: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
else
echo "$ac_err" >&5
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
CPP="${CC-cc} -nologo -E"
cat > conftest.$ac_ext <<EOF
#line 1872 "configure"
#include "confdefs.h"
#include <assert.h>
Syntax Error
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1878: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
:
else
echo "$ac_err" >&5
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
|
| ︙ | ︙ | |||
1872 1873 1874 1875 1876 1877 1878 | else ac_cv_prog_CPP="$CPP" fi echo "$ac_t""$CPP" 1>&6 ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'` echo $ac_n "checking for errno.h""... $ac_c" 1>&6 | | | | | 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 |
else
ac_cv_prog_CPP="$CPP"
fi
echo "$ac_t""$CPP" 1>&6
ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for errno.h""... $ac_c" 1>&6
echo "configure:1904: checking for errno.h" >&5
if eval "test \"`echo '$''{'ac_cv_header_$ac_safe'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1909 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1914: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out | grep -v "^conftest.${ac_ext}\$"`
if test -z "$ac_err"; then
rm -rf conftest*
eval "ac_cv_header_$ac_safe=yes"
else
echo "$ac_err" >&5
echo "configure: failed program was:" >&5
|
| ︙ | ︙ | |||
1925 1926 1927 1928 1929 1930 1931 |
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
eval "TCL_SRC_DIR=\"`cd $srcdir/..; pwd`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}"
| | | | | | | 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 |
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
eval "TCL_SRC_DIR=\"`cd $srcdir/..; pwd`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}"
eval "TCL_LIB_FLAG=\"-ltcl${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_LIB_SPEC=\"-L`pwd` ${TCL_LIB_FLAG}\""
eval "TCL_LIB_SPEC=\"-L${libdir} ${TCL_LIB_FLAG}\""
eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`pwd` ${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
eval "TCL_BUILD_STUB_LIB_PATH=\"`pwd`/${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
|
| ︙ | ︙ | |||
1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 |
if test "${DBGX}" = "g"; then
RC_DEFINES="${RC_DEFINE} DEBUG"
else
RC_DEFINES=""
fi
fi
| > > > > > > > > > > > > | 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 |
if test "${DBGX}" = "g"; then
RC_DEFINES="${RC_DEFINE} DEBUG"
else
RC_DEFINES=""
fi
fi
#--------------------------------------------------------------------
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$prefix" != "$exec_prefix"; then
TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
TCL_PACKAGE_PATH="${prefix}/lib"
fi
|
| ︙ | ︙ | |||
2058 2059 2060 2061 2062 2063 2064 |
| < < | 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 | trap '' 1 2 15 cat > confcache <<\EOF # This file is a shell script that caches the results of configure # tests run on this system so they can be shared between configure # scripts and configure runs. It is not useful on other systems. # If it contains results you don't want to keep, you may remove or edit it. # |
| ︙ | ︙ | |||
2126 2127 2128 2129 2130 2131 2132 | fi trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15 # Transform confdefs.h into DEFS. # Protect against shell expansion while executing Makefile rules. # Protect against Makefile macro expansion. | > > > > | > > > > | > > > | | | | > | > > > > > > > | | | 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 |
fi
trap 'rm -f $CONFIG_STATUS conftest*; exit 1' 1 2 15
# Transform confdefs.h into DEFS.
# Protect against shell expansion while executing Makefile rules.
# Protect against Makefile macro expansion.
#
# If the first sed substitution is executed (which looks for macros that
# take arguments), then we branch to the quote section. Otherwise,
# look for a macro that doesn't take arguments.
cat >confdef2opt.sed <<\_ACEOF
t clear
: clear
s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\),-D\1=\2,g
t quote
s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\),-D\1=\2,g
t quote
d
: quote
s,[ `~#$^&*(){}\\|;'"<>?],\\&,g
s,\[,\\&,g
s,\],\\&,g
s,\$,$$,g
p
_ACEOF
# We use echo to avoid assuming a particular line-breaking character.
# The extra dot is to prevent the shell from consuming trailing
# line-breaks from the sub-command output. A line-break within
# single-quotes doesn't work because, if this script is created in a
# platform that uses two characters for line-breaks (e.g., DOS), tr
# would break.
ac_LF_and_DOT=`echo; echo .`
DEFS=`sed -n -f confdef2opt.sed confdefs.h | tr "$ac_LF_and_DOT" ' .'`
rm -f confdef2opt.sed
# Without the "./", some shells look in PATH for config.status.
: ${CONFIG_STATUS=./config.status}
echo creating $CONFIG_STATUS
rm -f $CONFIG_STATUS
|
| ︙ | ︙ | |||
2277 2278 2279 2280 2281 2282 2283 | s%@TCL_EXP_FILE@%$TCL_EXP_FILE%g s%@LIBOBJS@%$LIBOBJS%g s%@TCL_LIB_VERSIONS_OK@%$TCL_LIB_VERSIONS_OK%g s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g s%@TCL_DDE_VERSION@%$TCL_DDE_VERSION%g s%@TCL_DDE_MAJOR_VERSION@%$TCL_DDE_MAJOR_VERSION%g s%@TCL_DDE_MINOR_VERSION@%$TCL_DDE_MINOR_VERSION%g | < < | 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 | s%@TCL_EXP_FILE@%$TCL_EXP_FILE%g s%@LIBOBJS@%$LIBOBJS%g s%@TCL_LIB_VERSIONS_OK@%$TCL_LIB_VERSIONS_OK%g s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g s%@TCL_DDE_VERSION@%$TCL_DDE_VERSION%g s%@TCL_DDE_MAJOR_VERSION@%$TCL_DDE_MAJOR_VERSION%g s%@TCL_DDE_MINOR_VERSION@%$TCL_DDE_MINOR_VERSION%g s%@TCL_REG_VERSION@%$TCL_REG_VERSION%g s%@TCL_REG_MAJOR_VERSION@%$TCL_REG_MAJOR_VERSION%g s%@TCL_REG_MINOR_VERSION@%$TCL_REG_MINOR_VERSION%g s%@RC_OUT@%$RC_OUT%g s%@RC_TYPE@%$RC_TYPE%g s%@RC_INCLUDE@%$RC_INCLUDE%g s%@RC_DEFINE@%$RC_DEFINE%g s%@RC_DEFINES@%$RC_DEFINES%g s%@RES@%$RES%g |
| ︙ | ︙ |
Changes to win/configure.in.
1 2 3 4 5 | #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. # | | | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
#! /bin/bash -norc
# This file is an input file used by the GNU "autoconf" program to
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
#
# RCS: @(#) $Id: configure.in,v 1.68.2.20 2007/05/30 14:05:22 dgp Exp $
AC_INIT(../generic/tcl.h)
AC_PREREQ(2.13)
TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL=".16"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.2
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=2
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
TCL_REG_VERSION=1.1
TCL_REG_MAJOR_VERSION=1
TCL_REG_MINOR_VERSION=1
REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION
#------------------------------------------------------------------------
# Handle the --prefix=... option
#------------------------------------------------------------------------
if test "${prefix}" = "NONE"; then
|
| ︙ | ︙ | |||
305 306 307 308 309 310 311 |
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
eval "TCL_SRC_DIR=\"`cd $srcdir/..; pwd`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}"
| | | | | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}"
eval "TCL_SRC_DIR=\"`cd $srcdir/..; pwd`\""
eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}"
eval "TCL_LIB_FLAG=\"-ltcl${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_LIB_SPEC=\"-L`pwd` ${TCL_LIB_FLAG}\""
eval "TCL_LIB_SPEC=\"-L${libdir} ${TCL_LIB_FLAG}\""
eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\""
eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`pwd` ${TCL_STUB_LIB_FLAG}\""
eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\""
eval "TCL_BUILD_STUB_LIB_PATH=\"`pwd`/${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\""
# Install time header dir can be set via --includedir
eval "TCL_INCLUDE_SPEC=\"-I${includedir}\""
|
| ︙ | ︙ | |||
349 350 351 352 353 354 355 356 357 358 359 360 361 362 |
if test "${DBGX}" = "g"; then
RC_DEFINES="${RC_DEFINE} DEBUG"
else
RC_DEFINES=""
fi
fi
AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_MAJOR_VERSION)
AC_SUBST(TCL_MINOR_VERSION)
AC_SUBST(TCL_PATCH_LEVEL)
AC_SUBST(TCL_LIB_FILE)
| > > > > > > > > > > > > | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
if test "${DBGX}" = "g"; then
RC_DEFINES="${RC_DEFINE} DEBUG"
else
RC_DEFINES=""
fi
fi
#--------------------------------------------------------------------
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$prefix" != "$exec_prefix"; then
TCL_PACKAGE_PATH="${libdir} ${prefix}/lib"
else
TCL_PACKAGE_PATH="${prefix}/lib"
fi
AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_MAJOR_VERSION)
AC_SUBST(TCL_MINOR_VERSION)
AC_SUBST(TCL_PATCH_LEVEL)
AC_SUBST(TCL_LIB_FILE)
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 | AC_SUBST(TCL_LIB_VERSIONS_OK) AC_SUBST(TCL_PACKAGE_PATH) # win only AC_SUBST(TCL_DDE_VERSION) AC_SUBST(TCL_DDE_MAJOR_VERSION) AC_SUBST(TCL_DDE_MINOR_VERSION) | < < | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 | AC_SUBST(TCL_LIB_VERSIONS_OK) AC_SUBST(TCL_PACKAGE_PATH) # win only AC_SUBST(TCL_DDE_VERSION) AC_SUBST(TCL_DDE_MAJOR_VERSION) AC_SUBST(TCL_DDE_MINOR_VERSION) AC_SUBST(TCL_REG_VERSION) AC_SUBST(TCL_REG_MAJOR_VERSION) AC_SUBST(TCL_REG_MINOR_VERSION) AC_SUBST(RC) AC_SUBST(RC_OUT) AC_SUBST(RC_TYPE) AC_SUBST(RC_INCLUDE) AC_SUBST(RC_DEFINE) AC_SUBST(RC_DEFINES) AC_SUBST(RES) AC_OUTPUT(Makefile tclConfig.sh tcl.hpj) |
Changes to win/makefile.bc.
| ︙ | ︙ | |||
396 397 398 399 400 401 402 | -@$(MKDIR) "$(LIB_INSTALL_DIR)" -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)" -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)" @echo installing http1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" | | | | | | 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 | -@$(MKDIR) "$(LIB_INSTALL_DIR)" -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)" -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)" @echo installing http1.0 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0" @echo installing http2.5 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.5" -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.5" -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.5" @echo installing opt0.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" @echo installing msgcat1.3 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.3" -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.3" |
| ︙ | ︙ |
Changes to win/makefile.vc.
1 2 3 4 5 6 7 8 9 10 | #------------------------------------------------------------------------------ # makefile.vc -- # # Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. | | | > > | > | | > | | | | > | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | #------------------------------------------------------------------------------ # makefile.vc -- # # Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+) # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001-2005 ActiveState Corporation. # Copyright (c) 2001-2002 David Gravereaux. # #------------------------------------------------------------------------------ # RCS: @(#) $Id: makefile.vc,v 1.100.2.9 2006/09/26 21:40:36 patthoyts Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) # or with the MS Platform SDK (MSSDK). Visual Studio .NET 2003 and 2005 define # VCINSTALLDIR instead. !if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(MSSDK) && !defined(VCINSTALLDIR) MSG = ^ You need to run vcvars32.bat from Developer Studio or setenv.bat from the^ Platform SDK first to setup the environment. Jump to this line to read^ the build instructions. !error $(MSG) !endif #------------------------------------------------------------------------------ # HOW TO USE this makefile: # # 1) It is now necessary to have MSVCDir, MSDevDir or MSSDK set in the # environment. This is used as a check to see if vcvars32.bat had been # run prior to running nmake or during the installation of Microsoft # Visual C++, MSVCDir had been set globally and the PATH adjusted. # Either way is valid. # # You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin # directory to setup the proper environment, if needed, for your # current setup. This is a needed bootstrap requirement and allows the # swapping of different environments to be easier. # # 2) To use the Platform SDK (not expressly needed), run setenv.bat after # vcvars32.bat according to the instructions for it. This can also # turn on the 64-bit compiler, if your SDK has it. # # 3) Targets are: # release -- Builds the core, the shell and the dlls. (default) # dlls -- Just builds the windows extensions and the 16-bit DOS # pipe/thunk helper app. # shell -- Just builds the shell and the core. # core -- Only builds the core [tclXX.(dll|lib)]. |
| ︙ | ︙ | |||
172 173 174 175 176 177 178 | TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe TCLSH = $(OUT_DIR)\$(TCLSHNAME) | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCLSHNAME = $(PROJECT)sh$(VERSION)$(SUFX).exe TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLPIPEDLLNAME = $(PROJECT)pip$(VERSION)$(SUFX:t=).dll TCLPIPEDLL = $(OUT_DIR)\$(TCLPIPEDLLNAME) TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT) TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME) TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT) TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) |
| ︙ | ︙ | |||
314 315 316 317 318 319 320 | #--------------------------------------------------------------------- # Compile flags #--------------------------------------------------------------------- !if !$(DEBUG) !if $(OPTIMIZING) ### This cranks the optimization level to maximize speed | | | | > | | | | < < | | > | | > > > > | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 | #--------------------------------------------------------------------- # Compile flags #--------------------------------------------------------------------- !if !$(DEBUG) !if $(OPTIMIZING) ### This cranks the optimization level to maximize speed cdebug = -O2 $(OPTIMIZATIONS) !else cdebug = !endif !else if "$(MACHINE)" == "IA64" ### Warnings are too many, can't support warnings into errors. cdebug = -Z7 -Od $(DEBUGFLAGS) !else cdebug = -Z7 -WX $(DEBUGFLAGS) !endif ### Declarations common to all compiler options cwarn = -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE cflags = -nologo -c $(COMPILERFLAGS) $(cwarn) -Fp$(TMP_DIR)^\ !if $(FULLWARNINGS) cflags = $(cflags) -W4 !else cflags = $(cflags) -W3 !endif !if $(MSVCRT) !if "$(DBGX)" == "" crt = -MD !else crt = -MDd !endif !else !if "$(DBGX)" == "" crt = -MT !else crt = -MTd !endif !endif TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) \ -DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) #--------------------------------------------------------------------- # Link flags #--------------------------------------------------------------------- !if $(DEBUG) ldebug = -debug:full -debugtype:cv !else ldebug = -release -opt:ref -opt:icf,3 !endif ### Declarations common to all linker options lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(FULLWARNINGS) lflags = $(lflags) -warn:3 !endif !if $(PROFILE) lflags = $(lflags) -profile !endif !if $(ALIGN98_HACK) && !$(STATIC_BUILD) ### Align sections for PE size savings. |
| ︙ | ︙ | |||
389 390 391 392 393 394 395 | lflags = $(lflags) -ws:aggressive !endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows | | | > > > > | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 | lflags = $(lflags) -ws:aggressive !endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows baselibs = kernel32.lib advapi32.lib user32.lib # Avoid 'unresolved external symbol __security_cookie' errors. # c.f. http://support.microsoft.com/?id=894573 !if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" baselibs = $(baselibs) bufferoverflowU.lib !endif #--------------------------------------------------------------------- # TclTest flags #--------------------------------------------------------------------- !IF "$(TESTPAT)" != "" TESTFLAGS = -file $(TESTPAT) |
| ︙ | ︙ | |||
417 418 419 420 421 422 423 | tcltest: setup $(TCLTEST) dlls $(CAT32) install: install-binaries install-libraries install-docs test: setup $(TCLTEST) dlls $(CAT32) set TCL_LIBRARY=$(ROOT)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" | | | | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 |
tcltest: setup $(TCLTEST) dlls $(CAT32)
install: install-binaries install-libraries install-docs
test: setup $(TCLTEST) dlls $(CAT32)
set TCL_LIBRARY=$(ROOT)/library
!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE"
$(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS)
!else
$(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) > tests.log
type tests.log | more
!endif
runtest: setup $(TCLTEST) dlls $(CAT32)
set TCL_LIBRARY=$(ROOT)/library
$(TCLTEST)
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 | $** << !else $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcl -out:$@ \ $(baselibs) @<< $** << -@del $*.exp !endif $(TCLSTUBLIB): $(TCLSTUBOBJS) $(lib32) -nologo -out:$@ $(TCLSTUBOBJS) $(TCLSH): $(TCLSHOBJS) $(TCLIMPLIB) $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** $(TCLTEST): $(TCLTESTOBJS) $(TCLIMPLIB) $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $** $(TCLPIPEDLL): $(WINDIR)\stub16.c $(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $(WINDIR)\stub16.c $(link32) $(conlflags) -out:$@ $(TMP_DIR)\stub16.obj $(baselibs) !if $(STATIC_BUILD) $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(lib32) -nologo -out:$@ $(TMP_DIR)\tclWinDde.obj !else $(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB) $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \ $** $(baselibs) -@del $*.exp -@del $*.lib !endif !if $(STATIC_BUILD) $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(lib32) -nologo -out:$@ $(TMP_DIR)\tclWinReg.obj !else $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \ $** $(baselibs) -@del $*.exp -@del $*.lib !endif $(CAT32): $(WINDIR)\cat.c $(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $? $(link32) $(conlflags) -out:$@ -stack:16384 $(TMP_DIR)\cat.obj \ $(baselibs) | > > > > > > | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 |
$**
<<
!else
$(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcl -out:$@ \
$(baselibs) @<<
$**
<<
$(_VC_MANIFEST_EMBED_DLL)
-@del $*.exp
!endif
$(TCLSTUBLIB): $(TCLSTUBOBJS)
$(lib32) -nologo -out:$@ $(TCLSTUBOBJS)
$(TCLSH): $(TCLSHOBJS) $(TCLIMPLIB)
$(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $**
$(_VC_MANIFEST_EMBED_EXE)
$(TCLTEST): $(TCLTESTOBJS) $(TCLIMPLIB)
$(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $**
$(_VC_MANIFEST_EMBED_EXE)
$(TCLPIPEDLL): $(WINDIR)\stub16.c
$(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $(WINDIR)\stub16.c
$(link32) $(conlflags) -out:$@ $(TMP_DIR)\stub16.obj $(baselibs)
$(_VC_MANIFEST_EMBED_DLL)
!if $(STATIC_BUILD)
$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj
$(lib32) -nologo -out:$@ $(TMP_DIR)\tclWinDde.obj
!else
$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB)
$(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \
$** $(baselibs)
$(_VC_MANIFEST_EMBED_DLL)
-@del $*.exp
-@del $*.lib
!endif
!if $(STATIC_BUILD)
$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj
$(lib32) -nologo -out:$@ $(TMP_DIR)\tclWinReg.obj
!else
$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB)
$(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \
$** $(baselibs)
$(_VC_MANIFEST_EMBED_DLL)
-@del $*.exp
-@del $*.lib
!endif
$(CAT32): $(WINDIR)\cat.c
$(cc32) $(CON_CFLAGS) -Fo$(TMP_DIR)\ $?
$(link32) $(conlflags) -out:$@ -stack:16384 $(TMP_DIR)\cat.obj \
$(baselibs)
$(_VC_MANIFEST_EMBED_EXE)
#---------------------------------------------------------------------
# Regenerate the stubs files. [Development use only]
#---------------------------------------------------------------------
genstubs:
!if !exist($(TCLSH))
|
| ︙ | ︙ | |||
615 616 617 618 619 620 621 | !endif ### The following objects should be built using the stub interfaces ### *ALL* extensions need to built with -DTCL_THREADS=1 $(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c !if $(STATIC_BUILD) | | | | | | | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 | !endif ### The following objects should be built using the stub interfaces ### *ALL* extensions need to built with -DTCL_THREADS=1 $(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c !if $(STATIC_BUILD) $(cc32) $(BASE_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? !else $(cc32) $(BASE_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? !endif $(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c !if $(STATIC_BUILD) $(cc32) $(BASE_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $? !else $(cc32) $(BASE_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $? !endif ### The following objects are part of the stub library and should not ### be built as DLL objects. -Zl is used to avoid a dependancy on any ### specific C run-time. $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(cc32) $(cdebug) $(cflags) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $? #--------------------------------------------------------------------- # Dedependency rules |
| ︙ | ︙ | |||
733 734 735 736 737 738 739 | @echo installing $(TCLSTUBLIBNAME) @$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\" install-libraries: @echo installing http1.0 @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\http1.0\" | | | | 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 | @echo installing $(TCLSTUBLIBNAME) @$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\" install-libraries: @echo installing http1.0 @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\http1.0\" @echo installing http2.5 @$(CPY) "$(ROOT)\library\http\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\http2.5\" @echo installing opt0.4 @$(CPY) "$(ROOT)\library\opt\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\opt0.4\" @echo installing msgcat1.3 @$(CPY) "$(ROOT)\library\msgcat\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\msgcat1.3\" @echo installing tcltest2.2 |
| ︙ | ︙ |
Changes to win/nmakehlp.c.
|
| > | | > > > > > > > > > > > > > > > | | | > | > > > | | | > > < > > | > > > > > > > > > > > > > > | | > > | | > > | | | | > > | > > > > > > > > > > > > | > | > > | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
/*
* ----------------------------------------------------------------------------
* nmakehlp.c --
*
* This is used to fix limitations within nmake and the environment.
*
* Copyright (c) 2002 by David Gravereaux.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* ----------------------------------------------------------------------------
* RCS: @(#) $Id: nmakehlp.c,v 1.1.4.4 2006/10/18 08:49:33 patthoyts Exp $
* ----------------------------------------------------------------------------
*/
#define _CRT_SECURE_NO_DEPRECATE
#include <windows.h>
#pragma comment (lib, "user32.lib")
#pragma comment (lib, "kernel32.lib")
#include <stdio.h>
#include <math.h>
#if defined(_M_IA64) || defined(_M_AMD64)
#pragma comment(lib, "bufferoverflowU")
#endif
/* ISO hack for dumb VC++ */
#ifdef _MSC_VER
#define snprintf _snprintf
#endif
/* protos */
int CheckForCompilerFeature(const char *option);
int CheckForLinkerFeature(const char *option);
int IsIn(const char *string, const char *substring);
int GrepForDefine(const char *file, const char *string);
DWORD WINAPI ReadFromPipe(LPVOID args);
/* globals */
#define CHUNK 25
#define STATICBUFFERSIZE 1000
typedef struct {
HANDLE pipe;
char buffer[STATICBUFFERSIZE];
} pipeinfo;
pipeinfo Out = {INVALID_HANDLE_VALUE, '\0'};
pipeinfo Err = {INVALID_HANDLE_VALUE, '\0'};
/*
* exitcodes: 0 == no, 1 == yes, 2 == error
*/
int
main(
int argc,
char *argv[])
{
char msg[300];
DWORD dwWritten;
int chars;
/*
* Make sure children (cl.exe and link.exe) are kept quiet.
*/
SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOOPENFILEERRORBOX);
/*
* Make sure the compiler and linker aren't effected by the outside world.
*/
SetEnvironmentVariable("CL", "");
SetEnvironmentVariable("LINK", "");
if (argc > 1 && *argv[1] == '-') {
switch (*(argv[1]+1)) {
case 'c':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -c <compiler option>\n"
"Tests for whether cl.exe supports an option\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return CheckForCompilerFeature(argv[2]);
case 'l':
if (argc != 3) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -l <linker option>\n"
"Tests for whether link.exe supports an option\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return CheckForLinkerFeature(argv[2]);
case 'f':
if (argc == 2) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -f <string> <substring>\n"
"Find a substring within another\n"
"exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
} else if (argc == 3) {
/*
* If the string is blank, there is no match.
*/
return 0;
} else {
return IsIn(argv[2], argv[3]);
}
case 'g':
if (argc == 2) {
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -g <file> <string>\n"
"grep for a #define\n"
"exitcodes: integer of the found string (no decimals)\n",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars,
&dwWritten, NULL);
return 2;
}
return GrepForDefine(argv[2], argv[3]);
}
}
chars = snprintf(msg, sizeof(msg) - 1,
"usage: %s -c|-l|-f ...\n"
"This is a little helper app to equalize shell differences between WinNT and\n"
"Win9x and get nmake.exe to accomplish its job.\n",
argv[0]);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL);
return 2;
}
int
CheckForCompilerFeature(
const char *option)
{
STARTUPINFO si;
PROCESS_INFORMATION pi;
SECURITY_ATTRIBUTES sa;
DWORD threadID;
char msg[300];
BOOL ok;
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
si.hStdInput = INVALID_HANDLE_VALUE;
ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
sa.lpSecurityDescriptor = NULL;
sa.bInheritHandle = FALSE;
| > | > > > | > > | | > | > > | | > | > > | > > | > > | > > | > > | > | | | | > | > > > | > > > | > > < < < | | > > > | > > > | > > > | | > | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
si.hStdInput = INVALID_HANDLE_VALUE;
ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
sa.lpSecurityDescriptor = NULL;
sa.bInheritHandle = FALSE;
/*
* Create a non-inheritible pipe.
*/
CreatePipe(&Out.pipe, &h, &sa, 0);
/*
* Dupe the write side, make it inheritible, and close the original.
*/
DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Same as above, but for the error side.
*/
CreatePipe(&Err.pipe, &h, &sa, 0);
DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Base command line.
*/
lstrcpy(cmdline, "cl.exe -nologo -c -TC -Zs -X ");
/*
* Append our option for testing
*/
lstrcat(cmdline, option);
/*
* Filename to compile, which exists, but is nothing and empty.
*/
lstrcat(cmdline, " .\\nul");
ok = CreateProcess(
NULL, /* Module name. */
cmdline, /* Command line. */
NULL, /* Process handle not inheritable. */
NULL, /* Thread handle not inheritable. */
TRUE, /* yes, inherit handles. */
DETACHED_PROCESS, /* No console for you. */
NULL, /* Use parent's environment block. */
NULL, /* Use parent's starting directory. */
&si, /* Pointer to STARTUPINFO structure. */
&pi); /* Pointer to PROCESS_INFORMATION structure. */
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
/*
* Close our references to the write handles that have now been inherited.
*/
CloseHandle(si.hStdOutput);
CloseHandle(si.hStdError);
WaitForInputIdle(pi.hProcess, 5000);
CloseHandle(pi.hThread);
/*
* Start the pipe reader threads.
*/
pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
/*
* Block waiting for the process to end.
*/
WaitForSingleObject(pi.hProcess, INFINITE);
CloseHandle(pi.hProcess);
/*
* Wait for our pipe to get done reading, should it be a little slow.
*/
WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
CloseHandle(pipeThreads[0]);
CloseHandle(pipeThreads[1]);
/*
* Look for the commandline warning code in both streams.
* - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002.
*/
return !(strstr(Out.buffer, "D4002") != NULL
|| strstr(Err.buffer, "D4002") != NULL
|| strstr(Out.buffer, "D9002") != NULL
|| strstr(Err.buffer, "D9002") != NULL);
}
int
CheckForLinkerFeature(
const char *option)
{
STARTUPINFO si;
PROCESS_INFORMATION pi;
SECURITY_ATTRIBUTES sa;
DWORD threadID;
char msg[300];
BOOL ok;
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
si.hStdInput = INVALID_HANDLE_VALUE;
ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
sa.lpSecurityDescriptor = NULL;
sa.bInheritHandle = TRUE;
| > | > > > | > > | | > | > > | | > | > > | > > | > > | < < > | | | | > | > > > | > > > | > > > | > > > | > > | > > > | | > | > > > > | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 |
si.hStdInput = INVALID_HANDLE_VALUE;
ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES));
sa.nLength = sizeof(SECURITY_ATTRIBUTES);
sa.lpSecurityDescriptor = NULL;
sa.bInheritHandle = TRUE;
/*
* Create a non-inheritible pipe.
*/
CreatePipe(&Out.pipe, &h, &sa, 0);
/*
* Dupe the write side, make it inheritible, and close the original.
*/
DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Same as above, but for the error side.
*/
CreatePipe(&Err.pipe, &h, &sa, 0);
DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE,
DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE);
/*
* Base command line.
*/
lstrcpy(cmdline, "link.exe -nologo ");
/*
* Append our option for testing.
*/
lstrcat(cmdline, option);
ok = CreateProcess(
NULL, /* Module name. */
cmdline, /* Command line. */
NULL, /* Process handle not inheritable. */
NULL, /* Thread handle not inheritable. */
TRUE, /* yes, inherit handles. */
DETACHED_PROCESS, /* No console for you. */
NULL, /* Use parent's environment block. */
NULL, /* Use parent's starting directory. */
&si, /* Pointer to STARTUPINFO structure. */
&pi); /* Pointer to PROCESS_INFORMATION structure. */
if (!ok) {
DWORD err = GetLastError();
int chars = snprintf(msg, sizeof(msg) - 1,
"Tried to launch: \"%s\", but got error [%u]: ", cmdline, err);
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS|
FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars],
(300-chars), 0);
WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL);
return 2;
}
/*
* Close our references to the write handles that have now been inherited.
*/
CloseHandle(si.hStdOutput);
CloseHandle(si.hStdError);
WaitForInputIdle(pi.hProcess, 5000);
CloseHandle(pi.hThread);
/*
* Start the pipe reader threads.
*/
pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID);
pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID);
/*
* Block waiting for the process to end.
*/
WaitForSingleObject(pi.hProcess, INFINITE);
CloseHandle(pi.hProcess);
/*
* Wait for our pipe to get done reading, should it be a little slow.
*/
WaitForMultipleObjects(2, pipeThreads, TRUE, 500);
CloseHandle(pipeThreads[0]);
CloseHandle(pipeThreads[1]);
/*
* Look for the commandline warning code in the stderr stream.
*/
return !(strstr(Out.buffer, "LNK1117") != NULL ||
strstr(Err.buffer, "LNK1117") != NULL ||
strstr(Out.buffer, "LNK4044") != NULL ||
strstr(Err.buffer, "LNK4044") != NULL);
}
DWORD WINAPI
ReadFromPipe(
LPVOID args)
{
pipeinfo *pi = (pipeinfo *) args;
char *lastBuf = pi->buffer;
DWORD dwRead;
BOOL ok;
again:
if (lastBuf - pi->buffer + CHUNK > STATICBUFFERSIZE) {
CloseHandle(pi->pipe);
return (DWORD)-1;
}
ok = ReadFile(pi->pipe, lastBuf, CHUNK, &dwRead, 0L);
if (!ok || dwRead == 0) {
CloseHandle(pi->pipe);
return 0;
}
lastBuf += dwRead;
goto again;
return 0; /* makes the compiler happy */
}
int
IsIn(
const char *string,
const char *substring)
{
return (strstr(string, substring) != NULL);
}
/*
* Find a specified #define by name.
*
* If the line is '#define TCL_VERSION "8.5"', it returns 85 as the result.
*/
int
GrepForDefine(
const char *file,
const char *string)
{
FILE *f;
char s1[51], s2[51], s3[51];
int r = 0;
double d1;
f = fopen(file, "rt");
if (f == NULL) {
return 0;
}
do {
r = fscanf(f, "%50s", s1);
if (r == 1 && !strcmp(s1, "#define")) {
/*
* Get next two words.
*/
r = fscanf(f, "%50s %50s", s2, s3);
if (r != 2) {
continue;
}
/*
* Is the first word what we're looking for?
*/
if (!strcmp(s2, string)) {
fclose(f);
/*
* Add 1 past first double quote char. "8.5"
*/
d1 = atof(s3 + 1); /* 8.5 */
while (floor(d1) != d1) {
d1 *= 10.0;
}
return ((int) d1); /* 85 */
}
}
} while (!feof(f));
fclose(f);
return 0;
}
|
Changes to win/rules.vc.
1 2 3 4 5 6 7 8 9 | #------------------------------------------------------------------------------ # rules.vc -- # # Microsoft Visual C++ makefile include for decoding the commandline # macros. This file does not need editing to build Tcl. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # | | > | | > > > > > > > | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < > > > | > > > > > > > > > > < | | | < | | | > | > > | > > > > > > > > > > | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 | #------------------------------------------------------------------------------ # rules.vc -- # # Microsoft Visual C++ makefile include for decoding the commandline # macros. This file does not need editing to build Tcl. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. # Copyright (c) 2003-2006 Patrick Thoyts # #------------------------------------------------------------------------------ # RCS: @(#) $Id: rules.vc,v 1.11.2.6 2006/10/31 15:17:20 patthoyts Exp $ #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 cc32 = $(CC) # built-in default. link32 = link lib32 = lib rc32 = $(RC) # built-in default. !ifndef INSTALLDIR ### Assume the normal default. _INSTALLDIR = C:\Program Files\Tcl !else ### Fix the path separators. _INSTALLDIR = $(INSTALLDIR:/=\) !endif !ifndef MACHINE !if "$(CPU)" == "" || "$(CPU)" == "i386" MACHINE = IX86 !else MACHINE = $(CPU) !endif !endif !ifndef CFG_ENCODING CFG_ENCODING = \"cp1252\" !endif #---------------------------------------------------------- # Set the proper copy method to avoid overwrite questions # to the user when copying files and selecting the right # "delete all" method. #---------------------------------------------------------- !if "$(OS)" == "Windows_NT" RMDIR = rmdir /S /Q !if ![ver | find "4.0" > nul] CPY = echo y | xcopy /i !else CPY = xcopy /i /y >NUL !endif !else CPY = xcopy /i RMDIR = deltree /Y !endif MKDIR = mkdir COPY = copy /y >NUL !message =============================================================================== #---------------------------------------------------------- # build the helper app we need to overcome nmake's limiting # environment. #---------------------------------------------------------- !if !exist(nmakehlp.exe) !if [$(cc32) -nologo nmakehlp.c -link -subsystem:console > nul] !endif !endif #---------------------------------------------------------- # Test for compiler features #---------------------------------------------------------- ### test for optimizations !if [nmakehlp -c -Ot] !message *** Compiler has 'Optimizations' OPTIMIZING = 1 !else !message *** Compiler doesn't have 'Optimizations' OPTIMIZING = 0 !endif OPTIMIZATIONS = !if [nmakehlp -c -Ot] OPTIMIZATIONS = $(OPTIMIZATIONS) -Ot !endif !if [nmakehlp -c -Oi] OPTIMIZATIONS = $(OPTIMIZATIONS) -Oi !endif !if [nmakehlp -c -Op] OPTIMIZATIONS = $(OPTIMIZATIONS) -Op !endif !if [nmakehlp -c -fp:strict] OPTIMIZATIONS = $(OPTIMIZATIONS) -fp:strict !endif !if [nmakehlp -c -Gs] OPTIMIZATIONS = $(OPTIMIZATIONS) -Gs !endif !if [nmakehlp -c -GS] OPTIMIZATIONS = $(OPTIMIZATIONS) -GS !endif !if [nmakehlp -c -GL] OPTIMIZATIONS = $(OPTIMIZATIONS) -GL !endif DEBUGFLAGS = !if [nmakehlp -c -RTC1] DEBUGFLAGS = $(DEBUGFLAGS) -RTC1 !elseif [nmakehlp -c -GZ] DEBUGFLAGS = $(DEBUGFLAGS) -GZ !endif COMPILERFLAGS =-W3 # In v13 -GL and -YX are incompatible. !if [nmakehlp -c -YX] !if ![nmakehlp -c -GL] OPTIMIZATIONS = $(OPTIMIZATIONS) -YX !endif !endif !if "$(MACHINE)" == "IX86" ### test for pentium errata !if [nmakehlp -c -QI0f] !message *** Compiler has 'Pentium 0x0f fix' COMPILERFLAGS = $(COMPILERFLAGSS) -QI0f !else !message *** Compiler doesn't have 'Pentium 0x0f fix' !endif !endif !if "$(MACHINE)" == "IA64" ### test for Itanium errata !if [nmakehlp -c -QIA64_Bx] !message *** Compiler has 'B-stepping errata workarounds' COMPILERFLAGS = $(COMPILERFLAGS) -QIA64_Bx !else !message *** Compiler does not have 'B-stepping errata workarounds' !endif !endif !if "$(MACHINE)" == "IX86" ### test for -align:4096, when align:512 will do. !if [nmakehlp -l -opt:nowin98] !message *** Linker has 'Win98 alignment problem' ALIGN98_HACK = 1 !else !message *** Linker doesn't have 'Win98 alignment problem' ALIGN98_HACK = 0 !endif !else ALIGN98_HACK = 0 !endif LINKERFLAGS = !if [nmakehlp -l -ltcg] LINKERFLAGS =-ltcg !endif #---------------------------------------------------------- # MSVC8 (ships with Visual Studio 2005) generates a manifest # file that we should link into the binaries. This is how. #---------------------------------------------------------- _VC_MANIFEST_EMBED_EXE= _VC_MANIFEST_EMBED_DLL= !if ![cl /Zs /Tc NUL 2>&1 | find "Version 12" > NUL] VCVER=6 !elseif ![cl /Zs /Tc NUL 2>&1 | find "Version 13" > NUL] VCVER=7 !elseif ![cl /Zs /Tc NUL 2>&1 | find "Version 14" > NUL] VCVER=8 _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1 _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 !else VCVER=0 !endif #---------------------------------------------------------- # Decode the options requested. #---------------------------------------------------------- !if "$(OPTS)" == "" || [nmakehlp -f "$(OPTS)" "none"] STATIC_BUILD = 0 TCL_THREADS = 0 DEBUG = 0 PROFILE = 0 MSVCRT = 0 LOIMPACT = 0 TCL_USE_STATIC_PACKAGES = 0 USE_THREAD_ALLOC = 0 UNCHECKED = 0 !else !if [nmakehlp -f $(OPTS) "static"] !message *** Doing static STATIC_BUILD = 1 !else STATIC_BUILD = 0 !endif |
| ︙ | ︙ | |||
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 | !endif !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !else USE_THREAD_ALLOC = 0 !endif !endif !if !$(STATIC_BUILD) # Make sure we don't build overly fat DLLs. MSVCRT = 1 # We shouldn't statically put the extensions inside the shell when dynamic. TCL_USE_STATIC_PACKAGES = 0 !endif #---------------------------------------------------------- # Figure-out how to name our intermediate and output directories. # We wouldn't want different builds to use the same .obj files # by accident. #---------------------------------------------------------- SUFX = tsgx !if $(DEBUG) BUILDDIRTOP = Debug DBGX = g !else BUILDDIRTOP = Release DBGX = SUFX = $(SUFX:g=) !endif TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX !if !$(STATIC_BUILD) TMP_DIRFULL = $(TMP_DIRFULL:Static=) SUFX = $(SUFX:s=) EXT = dll | > > > > > > > > > > > > > > > > > > > > > > > | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 | !endif !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !else USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked UNCHECKED = 1 !else UNCHECKED = 0 !endif !endif !if !$(STATIC_BUILD) # Make sure we don't build overly fat DLLs. MSVCRT = 1 # We shouldn't statically put the extensions inside the shell when dynamic. TCL_USE_STATIC_PACKAGES = 0 !endif #---------------------------------------------------------- # Figure-out how to name our intermediate and output directories. # We wouldn't want different builds to use the same .obj files # by accident. #---------------------------------------------------------- #---------------------------------------- # Naming convention: # t = full thread support. # s = static library (as opposed to an # import library) # g = linked to the debug enabled C # run-time. # x = special static build when it # links to the dynamic C run-time. #---------------------------------------- SUFX = tsgx !if $(DEBUG) BUILDDIRTOP = Debug DBGX = g !else BUILDDIRTOP = Release DBGX = SUFX = $(SUFX:g=) !endif !if "$(MACHINE)" != "IX86" BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE) !endif !if $(VCVER) > 6 BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER) !endif TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX !if !$(STATIC_BUILD) TMP_DIRFULL = $(TMP_DIRFULL:Static=) SUFX = $(SUFX:s=) EXT = dll |
| ︙ | ︙ | |||
257 258 259 260 261 262 263 264 265 266 267 268 269 270 | !message *** Doing compdbg TCL_COMPILE_DEBUG = 1 !else TCL_COMPILE_DEBUG = 0 !endif !endif #---------------------------------------------------------- # Set our defines now armed with our options. #---------------------------------------------------------- OPTDEFINES = !if $(TCL_MEM_DEBUG) | > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > | > > | | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 |
!message *** Doing compdbg
TCL_COMPILE_DEBUG = 1
!else
TCL_COMPILE_DEBUG = 0
!endif
!endif
#----------------------------------------------------------
# Decode the checks requested.
#----------------------------------------------------------
!if "$(CHECKS)" == "" || [nmakehlp -f "$(CHECKS)" "none"]
TCL_NO_DEPRECATED = 0
FULLWARNINGS = 0
!else
!if [nmakehlp -f $(CHECKS) "nodep"]
!message *** Doing nodep check
TCL_NO_DEPRECATED = 1
!else
TCL_NO_DEPRECATED = 0
!endif
!if [nmakehlp -f $(CHECKS) "fullwarn"]
!message *** Doing full warnings check
FULLWARNINGS = 1
!else
FULLWARNINGS = 0
!endif
!endif
#----------------------------------------------------------
# Set our defines now armed with our options.
#----------------------------------------------------------
OPTDEFINES =
!if $(TCL_MEM_DEBUG)
OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG
!endif
!if $(TCL_COMPILE_DEBUG)
OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
!endif
!if $(TCL_THREADS)
OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1
!if $(USE_THREAD_ALLOC)
OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1
!endif
!endif
!if $(STATIC_BUILD)
OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD
!endif
!if $(DEBUG)
OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DEBUG
!elseif $(OPTIMIZING)
OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED
!endif
!if $(PROFILE)
OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED
!endif
!if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64"
OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT
!endif
#----------------------------------------------------------
# Get common info used when building extensions.
#----------------------------------------------------------
!if "$(PROJECT)" != "tcl"
!if !defined(TCLDIR)
!if exist("$(_INSTALLDIR)\include\tcl.h")
TCLH = "$(_INSTALLDIR)\include\tcl.h"
TCLINSTALL = 1
_TCLDIR = $(_INSTALLDIR)
!else
MSG=^
Failed to find tcl.h. Set the TCLDIR macro.
!error $(MSG)
!endif
!else
_TCLDIR = $(TCLDIR:/=\)
!if exist("$(_TCLDIR)\include\tcl.h")
TCLH = "$(_TCLDIR)\include\tcl.h"
TCLINSTALL = 1
!elseif exist("$(_TCLDIR)\generic\tcl.h")
TCLH = "$(_TCLDIR)\generic\tcl.h"
TCLINSTALL = 0
!else
MSG =^
Failed to find tcl.h. The TCLDIR macro does not appear correct.
!error $(MSG)
!endif
!endif
### TODO: add a command to nmakehlp.c to grep for Tcl's version from tcl.h.
### Because nmake can't return a string, we'll need to play games with return
### codes. It might look something like this:
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 359 360 | # Display stats being used. #---------------------------------------------------------- !message *** Intermediate directory will be '$(TMP_DIR)' !message *** Output directory will be '$(OUT_DIR)' !message *** Suffix for binaries will be '$(SUFX)' !message *** Optional defines are '$(OPTDEFINES)' !endif | > > > | 492 493 494 495 496 497 498 499 500 501 502 503 | # Display stats being used. #---------------------------------------------------------- !message *** Intermediate directory will be '$(TMP_DIR)' !message *** Output directory will be '$(OUT_DIR)' !message *** Suffix for binaries will be '$(SUFX)' !message *** Optional defines are '$(OPTDEFINES)' !message *** Compiler version $(VCVER) !message *** Compiler options '$(OPTIMIZATIONS) $(DEBUGFLAGS)' !message *** Link options '$(LINKERFLAGS)' !endif |
Changes to win/tcl.m4.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | # Adds the following arguments to configure: # --with-tcl=... # # Sets the following vars: # TCL_BIN_DIR Full path to the tclConfig.sh file #------------------------------------------------------------------------ | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
# Adds the following arguments to configure:
# --with-tcl=...
#
# Sets the following vars:
# TCL_BIN_DIR Full path to the tclConfig.sh file
#------------------------------------------------------------------------
AC_DEFUN([SC_PATH_TCLCONFIG], [
AC_MSG_CHECKING([the location of tclConfig.sh])
if test -d ../../tcl8.4$1/win; then
TCL_BIN_DIR_DEFAULT=../../tcl8.4$1/win
elif test -d ../../tcl8.4/win; then
TCL_BIN_DIR_DEFAULT=../../tcl8.4/win
else
|
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | # Adds the following arguments to configure: # --with-tk=... # # Sets the following vars: # TK_BIN_DIR Full path to the tkConfig.sh file #------------------------------------------------------------------------ | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
# Adds the following arguments to configure:
# --with-tk=...
#
# Sets the following vars:
# TK_BIN_DIR Full path to the tkConfig.sh file
#------------------------------------------------------------------------
AC_DEFUN([SC_PATH_TKCONFIG], [
AC_MSG_CHECKING([the location of tkConfig.sh])
if test -d ../../tk8.4$1/win; then
TK_BIN_DIR_DEFAULT=../../tk8.4$1/win
elif test -d ../../tk8.4/win; then
TK_BIN_DIR_DEFAULT=../../tk8.4/win
else
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | # Subst the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE # #------------------------------------------------------------------------ | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
# Subst the following vars:
# TCL_BIN_DIR
# TCL_SRC_DIR
# TCL_LIB_FILE
#
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TCLCONFIG], [
AC_MSG_CHECKING([for existence of $TCL_BIN_DIR/tclConfig.sh])
if test -f "$TCL_BIN_DIR/tclConfig.sh" ; then
AC_MSG_RESULT([loading])
. $TCL_BIN_DIR/tclConfig.sh
else
AC_MSG_RESULT([file not found])
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 | # # Results: # # Sets the following vars that should be in tkConfig.sh: # TK_BIN_DIR #------------------------------------------------------------------------ | | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
#
# Results:
#
# Sets the following vars that should be in tkConfig.sh:
# TK_BIN_DIR
#------------------------------------------------------------------------
AC_DEFUN([SC_LOAD_TKCONFIG], [
AC_MSG_CHECKING([for existence of $TK_BIN_DIR/tkConfig.sh])
if test -f "$TK_BIN_DIR/tkConfig.sh" ; then
AC_MSG_RESULT([loading])
. $TK_BIN_DIR/tkConfig.sh
else
AC_MSG_RESULT([could not find $TK_BIN_DIR/tkConfig.sh])
|
| ︙ | ︙ | |||
201 202 203 204 205 206 207 | # STATIC_BUILD Used for building import/export libraries # on Windows. # # Sets the following vars: # SHARED_BUILD Value of 1 or 0 #------------------------------------------------------------------------ | | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
# STATIC_BUILD Used for building import/export libraries
# on Windows.
#
# Sets the following vars:
# SHARED_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SHARED], [
AC_MSG_CHECKING([how to build libraries])
AC_ARG_ENABLE(shared,
[ --enable-shared build and link with shared libraries [--enable-shared]],
[tcl_ok=$enableval], [tcl_ok=yes])
if test "${enable_shared+set}" = set; then
enableval="$enable_shared"
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 | # Adds the following arguments to configure: # --enable-threads=yes|no # # Defines the following vars: # TCL_THREADS #------------------------------------------------------------------------ | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
# Adds the following arguments to configure:
# --enable-threads=yes|no
#
# Defines the following vars:
# TCL_THREADS
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_THREADS], [
AC_MSG_CHECKING(for building with threads)
AC_ARG_ENABLE(threads, [ --enable-threads build with threads],
[tcl_ok=$enableval], [tcl_ok=no])
if test "$tcl_ok" = "yes"; then
AC_MSG_RESULT(yes)
TCL_THREADS=1
|
| ︙ | ︙ | |||
288 289 290 291 292 293 294 | # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false # DBGX Debug library extension # #------------------------------------------------------------------------ | | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
# Sets to $(CFLAGS_OPTIMIZE) if false
# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true
# Sets to $(LDFLAGS_OPTIMIZE) if false
# DBGX Debug library extension
#
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no])
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
DBGX=""
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 | # LIBPREFIX # LIBRARIES # EXESUFFIX # DLLSUFFIX # #-------------------------------------------------------------------- | | | > > > > | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
# LIBPREFIX
# LIBRARIES
# EXESUFFIX
# DLLSUFFIX
#
#--------------------------------------------------------------------
AC_DEFUN([SC_CONFIG_CFLAGS], [
# Step 0: Enable 64 bit support?
AC_MSG_CHECKING([if 64bit support is requested])
AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable = amd64|ia64)], [do64bit=$enableval], [do64bit=no])
AC_MSG_RESULT($do64bit)
# Set some defaults (may get changed below)
EXTRA_CFLAGS=""
AC_CHECK_PROG(CYGPATH, cygpath, cygpath -w, echo)
SHLIB_SUFFIX=".dll"
# MACHINE is IX86 for LINK, but this is used by the manifest,
# which requires x86|amd64|ia64.
MACHINE="X86"
# Check for a bug in gcc's windres that causes the
# compile to fail when a Windows native path is
# passed into windres. The mingw toolchain requires
# Windows native paths while Cygwin should work
# with both. Avoid the bug by passing a POSIX
# path when using the Cygwin toolchain.
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
DEPARG='"$(shell $(CYGPATH) $<)"'
fi
# set various compiler flags depending on whether we are using gcc or cl
AC_MSG_CHECKING([compiler flags])
if test "${GCC}" = "yes" ; then
| | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 |
DEPARG='"$(shell $(CYGPATH) $<)"'
fi
# set various compiler flags depending on whether we are using gcc or cl
AC_MSG_CHECKING([compiler flags])
if test "${GCC}" = "yes" ; then
if test "$do64bit" != "no" ; then
AC_MSG_WARN("64bit mode not supported with GCC on Windows")
fi
SHLIB_LD=""
SHLIB_LD_LIBS=""
LIBS=""
LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32"
STLIB_LD='${AR} cr'
|
| ︙ | ︙ | |||
473 474 475 476 477 478 479 480 481 482 483 484 485 486 |
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=
MAKE_DLL="echo "
LIBSUFFIX="s\${DBGX}.a"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
else
# dynamic
AC_MSG_RESULT([using shared flags])
# ad-hoc check to see if CC supports -shared.
| > | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 |
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=
MAKE_DLL="echo "
LIBSUFFIX="s\${DBGX}.a"
LIBFLAGSUFFIX="s\${DBGX}"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
else
# dynamic
AC_MSG_RESULT([using shared flags])
# ad-hoc check to see if CC supports -shared.
|
| ︙ | ︙ | |||
496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
SHLIB_LD='${CC} -shared ${CFLAGS}'
SHLIB_LD_LIBS='${LIBS}'
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)"
LIBSUFFIX="\${DBGX}.a"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
| > | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
SHLIB_LD='${CC} -shared ${CFLAGS}'
SHLIB_LD_LIBS='${LIBS}'
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \
-Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)"
LIBSUFFIX="\${DBGX}.a"
LIBFLAGSUFFIX="\${DBGX}"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
fi
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wconversion"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
# Specify the CC output file names based on the target name
CC_OBJNAME="-o \[$]@"
CC_EXENAME="-o \[$]@"
|
| ︙ | ︙ | |||
539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 |
else
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=-MT
MAKE_DLL="echo "
LIBSUFFIX="s\${DBGX}.lib"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
SHLIB_LD_LIBS=""
else
# dynamic
AC_MSG_RESULT([using shared flags])
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
LIBSUFFIX="\${DBGX}.lib"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
SHLIB_LD_LIBS='${LIBS}'
fi
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
# This is a 2-stage check to make sure we have the 64-bit SDK
# We have to know where the SDK is installed.
| > > > | | < < | > > > > > > > > > > > | | > > > > > > | < < < < | < | | > | < | < | > > > > > > | | | > < < > > > | | | 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 |
else
if test "${SHARED_BUILD}" = "0" ; then
# static
AC_MSG_RESULT([using static flags])
runtime=-MT
MAKE_DLL="echo "
LIBSUFFIX="s\${DBGX}.lib"
LIBFLAGSUFFIX="s\${DBGX}"
LIBRARIES="\${STATIC_LIBRARIES}"
EXESUFFIX="s\${DBGX}.exe"
SHLIB_LD_LIBS=""
else
# dynamic
AC_MSG_RESULT([using shared flags])
runtime=-MD
# Add SHLIB_LD_LIBS to the Make rule, not here.
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
LIBSUFFIX="\${DBGX}.lib"
LIBFLAGSUFFIX="\${DBGX}"
EXESUFFIX="\${DBGX}.exe"
LIBRARIES="\${SHARED_LIBRARIES}"
SHLIB_LD_LIBS='${LIBS}'
fi
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
# This is a 2-stage check to make sure we have the 64-bit SDK
# We have to know where the SDK is installed.
# This magic is based on MS Platform SDK for Win2003 SP1 - hobbs
if test "$do64bit" != "no" ; then
if test "x${MSSDK}x" = "xx" ; then
MSSDK="C:/Progra~1/Microsoft Platform SDK"
fi
MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'`
PATH64=""
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # default to AMD64 64-bit build
PATH64="${MSSDK}/Bin/Win64/x86/AMD64"
;;
ia64)
MACHINE="IA64"
PATH64="${MSSDK}/Bin/Win64"
;;
esac
if test ! -d "${PATH64}" ; then
AC_MSG_WARN([Could not find 64-bit $MACHINE SDK to enable 64bit mode])
AC_MSG_WARN([Ensure latest Platform SDK is installed])
do64bit="no"
else
AC_MSG_RESULT([ Using 64-bit $MACHINE mode])
fi
fi
if test "$do64bit" != "no" ; then
# The space-based-path will work for the Makefile, but will
# not work if AC_TRY_COMPILE is called.
CC="\"${PATH64}/cl.exe\" -I\"${MSSDK}/Include\" \
-I\"${MSSDK}/Include/crt\" -I\"${MSSDK}/Include/crt/sys\""
RC="\"${MSSDK}/bin/rc.exe\""
CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"
# Do not use -O2 for Win64 - this has proved buggy in code gen.
CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}"
lflags="-nologo -MACHINE:${MACHINE} -LIBPATH:\"${MSSDK}/Lib/${MACHINE}\""
LINKBIN="\"${PATH64}/link.exe\""
# Avoid 'unresolved external symbol __security_cookie' errors.
# c.f. http://support.microsoft.com/?id=894573
LIBS="user32.lib advapi32.lib bufferoverflowU.lib"
else
RC="rc"
# -Od - no optimization
# -WX - warnings as errors
CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
# -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy)
CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}"
lflags="-nologo"
LINKBIN="link"
LIBS="user32.lib advapi32.lib"
fi
LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib"
SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
# link -lib only works when -lib is the first arg
STLIB_LD="${LINKBIN} -lib ${lflags}"
RC_OUT=-fo
RC_TYPE=-r
RC_INCLUDE=-i
RC_DEFINE=-d
RES=res
MAKE_LIB="\${STLIB_LD} -out:\[$]@"
POST_MAKE_LIB=
MAKE_EXE="\${CC} -Fe\[$]@"
LIBPREFIX=""
EXTRA_CFLAGS=""
CFLAGS_WARNING="-W3"
LDFLAGS_DEBUG="-debug:full"
LDFLAGS_OPTIMIZE="-release"
# Specify the CC output file names based on the target name
CC_OBJNAME="-Fo\[$]@"
CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\""
# Specify linker flags depending on the type of app being
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 | # Adds the following arguments to configure: # --with-tcl=... # # Defines the following vars: # TCL_BIN_DIR Full path to the tcl build dir. #------------------------------------------------------------------------ | | < < < < | > > > > | | | < | | | | | < | | < < > > > > > > > > > > > > > > > > > > > > > > > > > | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 |
# Adds the following arguments to configure:
# --with-tcl=...
#
# Defines the following vars:
# TCL_BIN_DIR Full path to the tcl build dir.
#------------------------------------------------------------------------
AC_DEFUN([SC_WITH_TCL], [
if test -d ../../tcl8.4$1/win; then
TCL_BIN_DEFAULT=../../tcl8.4$1/win
else
TCL_BIN_DEFAULT=../../tcl8.4/win
fi
AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.4 binaries from DIR],
TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`)
if test ! -d $TCL_BIN_DIR; then
AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist)
fi
if test ! -f $TCL_BIN_DIR/Makefile; then
AC_MSG_ERROR(There is no Makefile in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?)
else
echo "building against Tcl binaries in: $TCL_BIN_DIR"
fi
AC_SUBST(TCL_BIN_DIR)
])
#------------------------------------------------------------------------
# SC_PROG_TCLSH
# Locate a tclsh shell installed on the system path. This macro
# will only find a Tcl shell that already exists on the system.
# It will not find a Tcl shell in the Tcl build directory or
# a Tcl shell that has been installed from the Tcl build directory.
# If a Tcl shell can't be located on the PATH, then TCLSH_PROG will
# be set to "". Extensions should take care not to create Makefile
# rules that are run by default and depend on TCLSH_PROG. An
# extension can't assume that an executable Tcl shell exists at
# build time.
#
# Arguments
# none
#
# Results
# Subst's the following values:
# TCLSH_PROG
#------------------------------------------------------------------------
AC_DEFUN([SC_PROG_TCLSH], [
AC_MSG_CHECKING([for tclsh])
AC_CACHE_VAL(ac_cv_path_tclsh, [
search_path=`echo ${PATH} | sed -e 's/:/ /g'`
for dir in $search_path ; do
for j in `ls -r $dir/tclsh[[8-9]]*.exe 2> /dev/null` \
`ls -r $dir/tclsh* 2> /dev/null` ; do
if test x"$ac_cv_path_tclsh" = x ; then
if test -f "$j" ; then
ac_cv_path_tclsh=$j
break
fi
fi
done
done
])
if test -f "$ac_cv_path_tclsh" ; then
TCLSH_PROG="$ac_cv_path_tclsh"
AC_MSG_RESULT($TCLSH_PROG)
else
# It is not an error if an installed version of Tcl can't be located.
TCLSH_PROG=""
AC_MSG_RESULT([No tclsh found on PATH])
fi
AC_SUBST(TCLSH_PROG)
])
#------------------------------------------------------------------------
# SC_BUILD_TCLSH
# Determine the fully qualified path name of the tclsh executable
# in the Tcl build directory. This macro will correctly determine
# the name of the tclsh executable even if tclsh has not yet
# been built in the build directory. The build tclsh must be used
# when running tests from an extension build directory. It is not
# correct to use the TCLSH_PROG in cases like this.
#
# Arguments
# none
#
# Results
# Subst's the following values:
# BUILD_TCLSH
#------------------------------------------------------------------------
AC_DEFUN([SC_BUILD_TCLSH], [
AC_MSG_CHECKING([for tclsh in Tcl build directory])
BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT}
AC_MSG_RESULT($BUILD_TCLSH)
AC_SUBST(BUILD_TCLSH)
])
|
Changes to win/tclAppInit.c.
|
| | | > > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | /* * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit * procedure for Tcl applications (without Tk). Note that this * program must be built in Win32 console mode to work properly. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclAppInit.c,v 1.11.2.3 2007/03/19 17:06:26 dgp Exp $ */ #include "tcl.h" #include <windows.h> #include <locale.h> #ifdef TCL_TEST extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp)); extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp)); extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp)); extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp)); #ifdef TCL_THREADS extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp)); #endif #endif /* TCL_TEST */ static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr)); static BOOL __stdcall sigHandler (DWORD fdwCtrlType); static Tcl_AsyncProc asyncExit; static void AppInitExitHandler(ClientData clientData); static char ** argvSave = NULL; static Tcl_AsyncHandler exitToken = NULL; static DWORD exitErrorCode = 0; /* *---------------------------------------------------------------------- * * main -- * |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
{
/*
* The following #if block allows you to change the AppInit
* function by using a #define of TCL_LOCAL_APPINIT instead
* of rewriting this entire file. The #if checks for that
* #define and uses Tcl_AppInit if it doesn't exist.
*/
| | | | | > > > > > | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
{
/*
* The following #if block allows you to change the AppInit
* function by using a #define of TCL_LOCAL_APPINIT instead
* of rewriting this entire file. The #if checks for that
* #define and uses Tcl_AppInit if it doesn't exist.
*/
#ifndef TCL_LOCAL_APPINIT
#define TCL_LOCAL_APPINIT Tcl_AppInit
#endif
extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *interp));
/*
* The following #if block allows you to change how Tcl finds the startup
* script, prime the library or encoding paths, fiddle with the argv,
* etc., without needing to rewrite Tcl_Main()
*/
#ifdef TCL_LOCAL_MAIN_HOOK
extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv));
#endif
char buffer[MAX_PATH +1];
char *p;
/*
* Set up the default locale to be standard "C" locale so parsing
* is performed correctly.
*/
setlocale(LC_ALL, "C");
setargv(&argc, &argv);
/*
* Save this for later, so we can free it.
*/
argvSave = argv;
/*
* Replace argv[0] with full pathname of executable, and forward
* slashes substituted for backslashes.
*/
GetModuleFileName(NULL, buffer, sizeof(buffer));
argv[0] = buffer;
|
| ︙ | ︙ | |||
139 140 141 142 143 144 145 |
if (Tcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Install a signal handler to the win32 console tclsh is running in.
*/
| | | > > > > > > | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
if (Tcl_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Install a signal handler to the win32 console tclsh is running in.
*/
SetConsoleCtrlHandler(sigHandler, TRUE);
exitToken = Tcl_AsyncCreate(asyncExit, NULL);
/*
* This exit handler will be used to free the
* resources allocated in this file.
*/
Tcl_CreateExitHandler(AppInitExitHandler, NULL);
#ifdef TCL_TEST
if (Tcltest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
(Tcl_PackageInitProc *) NULL);
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 213 214 215 216 217 218 219 |
* where "app" is the name of the application. If this line is deleted
* then no user-specific startup file will be run under any conditions.
*/
Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
* setargv --
*
* Parse the Windows command line string into argc/argv. Done here
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
* where "app" is the name of the application. If this line is deleted
* then no user-specific startup file will be run under any conditions.
*/
Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AppInitExitHandler --
*
* This function is called to cleanup the app init resources before
* Tcl is unloaded.
*
* Results:
* None.
*
* Side effects:
* Frees the saved argv and deletes the async exit handler.
*
*----------------------------------------------------------------------
*/
static void
AppInitExitHandler(
ClientData clientData)
{
if (argvSave != NULL) {
ckfree((char *)argvSave);
argvSave = NULL;
}
if (exitToken != NULL) {
/*
* This should be safe to do even if we
* are in an async exit right now.
*/
Tcl_AsyncDelete(exitToken);
exitToken = NULL;
}
}
/*
*-------------------------------------------------------------------------
*
* setargv --
*
* Parse the Windows command line string into argc/argv. Done here
* because we don't trust the builtin argument parser in crt0.
* Windows applications are responsible for breaking their command
* line into arguments.
*
* 2N backslashes + quote -> N backslashes + begin quoted string
* 2N + 1 backslashes + quote -> literal
* N backslashes + non-quote -> literal
* quote + quote in a quoted string -> single quote
|
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
setargv(argcPtr, argvPtr)
int *argcPtr; /* Filled with number of argument strings. */
char ***argvPtr; /* Filled with argument strings (malloc'd). */
{
char *cmdLine, *p, *arg, *argSpace;
char **argv;
int argc, size, inquote, copy, slashes;
| | | | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 |
setargv(argcPtr, argvPtr)
int *argcPtr; /* Filled with number of argument strings. */
char ***argvPtr; /* Filled with argument strings (malloc'd). */
{
char *cmdLine, *p, *arg, *argSpace;
char **argv;
int argc, size, inquote, copy, slashes;
cmdLine = GetCommandLine(); /* INTL: BUG */
/*
* Precompute an overly pessimistic guess at the number of arguments
* in the command line by counting non-space spans.
*/
size = 2;
for (p = cmdLine; *p != '\0'; p++) {
if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
size++;
while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
break;
}
}
}
argSpace = (char *) ckalloc(
(unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1));
argv = (char **) argSpace;
argSpace += size * sizeof(char *);
size--;
p = cmdLine;
for (argc = 0; argc < size; argc++) {
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
argSpace = arg + 1;
}
argv[argc] = NULL;
*argcPtr = argc;
*argvPtr = argv;
}
| | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
argSpace = arg + 1;
}
argv[argc] = NULL;
*argcPtr = argc;
*argvPtr = argv;
}
/*
*----------------------------------------------------------------------
*
* asyncExit --
*
* The AsyncProc for the exitToken.
*
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 |
asyncExit (ClientData clientData, Tcl_Interp *interp, int code)
{
Tcl_Exit((int)exitErrorCode);
/* NOTREACHED */
return code;
}
| | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
asyncExit (ClientData clientData, Tcl_Interp *interp, int code)
{
Tcl_Exit((int)exitErrorCode);
/* NOTREACHED */
return code;
}
/*
*----------------------------------------------------------------------
*
* sigHandler --
*
* Signal handler for the Win32 OS. Catches Ctrl+C, Ctrl+Break and
* other exits. This is needed so tclsh can do it's real clean-up
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
*----------------------------------------------------------------------
*/
BOOL __stdcall
sigHandler(DWORD fdwCtrlType)
{
HANDLE hStdIn;
/*
* If Tcl is currently executing some bytecode or in the eventloop,
* this will cause Tcl to enter asyncExit at the next command
* boundry.
*/
exitErrorCode = fdwCtrlType;
Tcl_AsyncMark(exitToken);
| > > > > > > | | | | | | | | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
*----------------------------------------------------------------------
*/
BOOL __stdcall
sigHandler(DWORD fdwCtrlType)
{
HANDLE hStdIn;
if (!exitToken) {
/* Async token must have been destroyed, punt gracefully. */
return FALSE;
}
/*
* If Tcl is currently executing some bytecode or in the eventloop,
* this will cause Tcl to enter asyncExit at the next command
* boundry.
*/
exitErrorCode = fdwCtrlType;
Tcl_AsyncMark(exitToken);
/*
* This will cause Tcl_Gets in Tcl_Main() to drop-out with an <EOF>
* should it be blocked on input and our Tcl_AsyncMark didn't grab
* the attention of the interpreter.
*/
hStdIn = GetStdHandle(STD_INPUT_HANDLE);
if (hStdIn) {
CloseHandle(hStdIn);
}
/* indicate to the OS not to call the default terminator */
return TRUE;
}
|
Changes to win/tclWin32Dll.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclWin32Dll.c -- * * This file contains the DLL entry point. * * Copyright (c) 1995-1996 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclWin32Dll.c -- * * This file contains the DLL entry point. * * Copyright (c) 1995-1996 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWin32Dll.c,v 1.24.2.10 2006/10/17 04:36:45 dgp Exp $ */ #include "tclWinInt.h" /* * The following data structures are used when loading the thunking * library for execing child processes under Win32s. |
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | * on a per-instance basis. Each time this DLL is loaded, it gets its own * new data segment with its own copy of all static and global information. */ static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ static int platformId; /* Running under NT, or 95/98? */ | | | > > > > > | | > > > > > > > | | > | > > > > > > | | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
* on a per-instance basis. Each time this DLL is loaded, it gets its own
* new data segment with its own copy of all static and global information.
*/
static HINSTANCE hInstance; /* HINSTANCE of this DLL. */
static int platformId; /* Running under NT, or 95/98? */
#ifdef HAVE_NO_SEH
/*
* Unlike Borland and Microsoft, we don't register exception handlers
* by pushing registration records onto the runtime stack. Instead, we
* register them by creating an EXCEPTION_REGISTRATION within the activation
* record.
*/
typedef struct EXCEPTION_REGISTRATION {
struct EXCEPTION_REGISTRATION* link;
EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*,
struct _CONTEXT*, void* );
void* ebp;
void* esp;
int status;
} EXCEPTION_REGISTRATION;
#endif
/*
* VC++ 5.x has no 'cpuid' assembler instruction, so we
* must emulate it
*/
#if defined(_MSC_VER) && ( _MSC_VER <= 1100 )
#define cpuid __asm __emit 0fh __asm __emit 0a2h
#endif
/*
* The following function tables are used to dispatch to either the
* wide-character or multi-byte versions of the operating system calls,
* depending on whether the Unicode calls are available.
*/
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
(BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
(DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
WCHAR *, TCHAR **)) SearchPathA,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
/*
| | > > > > > > > > > | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
(BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
(DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
WCHAR *, TCHAR **)) SearchPathA,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
/*
* The three NULL function pointers will only be set when
* Tcl_FindExecutable is called. If you don't ever call that
* function, the application will crash whenever WinTcl tries to call
* functions through these null pointers. That is not a bug in Tcl
* -- Tcl_FindExecutable is obligatory in recent Tcl releases.
*/
NULL,
NULL,
(int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _utime,
NULL,
NULL,
/* getLongPathNameProc */
NULL,
/* Security SDK - not available on 95,98,ME */
NULL, NULL, NULL, NULL, NULL, NULL,
/* ReadConsole and WriteConsole */
(BOOL (WINAPI *)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID)) ReadConsoleA,
(BOOL (WINAPI *)(HANDLE, const VOID*, DWORD, LPDWORD, LPVOID)) WriteConsoleA
};
static TclWinProcs unicodeProcs = {
1,
(BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW,
(TCHAR *(WINAPI *)(TCHAR *)) CharLowerW,
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 |
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
(BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
(DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
WCHAR *, TCHAR **)) SearchPathW,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,
/*
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
(BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
(DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
WCHAR *, TCHAR **)) SearchPathW,
(BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
(BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,
/*
* The three NULL function pointers will only be set when
* Tcl_FindExecutable is called. If you don't ever call that
* function, the application will crash whenever WinTcl tries to call
* functions through these null pointers. That is not a bug in Tcl
* -- Tcl_FindExecutable is obligatory in recent Tcl releases.
*/
NULL,
NULL,
(int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _wutime,
NULL,
NULL,
/* getLongPathNameProc */
NULL,
/* Security SDK - will be filled in on NT,XP,2000,2003 */
NULL, NULL, NULL, NULL, NULL, NULL,
/* ReadConsole and WriteConsole */
(BOOL (WINAPI *)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID)) ReadConsoleW,
(BOOL (WINAPI *)(HANDLE, const VOID*, DWORD, LPDWORD, LPVOID)) WriteConsoleW
};
TclWinProcs *tclWinProcs;
static Tcl_Encoding tclWinTCharEncoding;
#ifdef HAVE_NO_SEH
/* Need to add noinline flag to DllMain declaration so that gcc -O3
* does not inline asm code into DllEntryPoint and cause a
* compile time error because of redefined local labels.
*/
BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
LPVOID reserved)
__attribute__ ((noinline));
#else
/*
* The following declaration is for the VC++ DLL entry point.
*/
BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
LPVOID reserved);
#endif /* HAVE_NO_SEH */
/*
* The following structure and linked list is to allow us to map between
* volume mount points and drive letters on the fly (no Win API exists
* for this).
*/
typedef struct MountPointMap {
CONST WCHAR* volumeName; /* Native wide string volume name */
char driveLetter; /* Drive letter corresponding to
* the volume name. */
struct MountPointMap* nextPtr; /* Pointer to next structure in list,
* or NULL */
} MountPointMap;
/*
* This is the head of the linked list, which is protected by the
* mutex which follows, for thread-enabled builds.
*/
MountPointMap *driveLetterLookup = NULL;
TCL_DECLARE_MUTEX(mountPointMap)
/* We will need this below */
extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
#ifdef __WIN32__
#ifndef STATIC_BUILD
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 214 215 216 217 218 219 |
*/
BOOL APIENTRY
DllMain(hInst, reason, reserved)
HINSTANCE hInst; /* Library instance handle. */
DWORD reason; /* Reason this function is being called. */
LPVOID reserved; /* Not used. */
{
switch (reason) {
case DLL_PROCESS_ATTACH:
TclWinInit(hInst);
return TRUE;
case DLL_PROCESS_DETACH:
| > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
*/
BOOL APIENTRY
DllMain(hInst, reason, reserved)
HINSTANCE hInst; /* Library instance handle. */
DWORD reason; /* Reason this function is being called. */
LPVOID reserved; /* Not used. */
{
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
#endif
switch (reason) {
case DLL_PROCESS_ATTACH:
DisableThreadLibraryCalls(hInst);
TclWinInit(hInst);
return TRUE;
case DLL_PROCESS_DETACH:
/*
* Protect the call to Tcl_Finalize. The OS could be unloading
* us from an exception handler and the state of the stack might
* be unstable.
*/
#ifdef HAVE_NO_SEH
__asm__ __volatile__ (
/*
* Construct an EXCEPTION_REGISTRATION to protect the
* call to Tcl_Finalize
*/
"leal %[registration], %%edx" "\n\t"
"movl %%fs:0, %%eax" "\n\t"
"movl %%eax, 0x0(%%edx)" "\n\t" /* link */
"leal 1f, %%eax" "\n\t"
"movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
"movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
"movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
"movl %[error], 0x10(%%edx)" "\n\t" /* status */
/*
* Link the EXCEPTION_REGISTRATION on the chain
*/
"movl %%edx, %%fs:0" "\n\t"
/*
* Call Tcl_Finalize
*/
"call _Tcl_Finalize" "\n\t"
/*
* Come here on a normal exit. Recover the EXCEPTION_REGISTRATION
* and store a TCL_OK status
*/
"movl %%fs:0, %%edx" "\n\t"
"movl %[ok], %%eax" "\n\t"
"movl %%eax, 0x10(%%edx)" "\n\t"
"jmp 2f" "\n"
/*
* Come here on an exception. Get the EXCEPTION_REGISTRATION
* that we previously put on the chain.
*/
"1:" "\t"
"movl %%fs:0, %%edx" "\n\t"
"movl 0x8(%%edx), %%edx" "\n"
/*
* Come here however we exited. Restore context from the
* EXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
"2:" "\t"
"movl 0xc(%%edx), %%esp" "\n\t"
"movl 0x8(%%edx), %%ebp" "\n\t"
"movl 0x0(%%edx), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
:
/* No outputs */
:
[registration] "m" (registration),
[ok] "i" (TCL_OK),
[error] "i" (TCL_ERROR)
:
"%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
);
#else /* HAVE_NO_SEH */
__try {
Tcl_Finalize();
} __except (EXCEPTION_EXECUTE_HANDLER) {
/* empty handler body. */
}
#endif
break;
}
return TRUE;
}
#endif /* !STATIC_BUILD */
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 |
*
*----------------------------------------------------------------------
*/
int
TclpCheckStackSpace()
{
int retval = 0;
/*
* We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD
* bytes of stack space left. alloca() is cheap on windows; basically
* it just subtracts from the stack pointer causing the OS to throw an
* exception if the stack pointer is set below the bottom of the stack.
*/
#ifdef HAVE_NO_SEH
| > > > > < | > > > > | | > > > > > > | > > > > | > > > > | > > > | > > > > > > > > > > > > > > > | > > > > | > | > > > | > > > > > > > > > > > | | < | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 |
*
*----------------------------------------------------------------------
*/
int
TclpCheckStackSpace()
{
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
#endif
int retval = 0;
/*
* We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD
* bytes of stack space left. alloca() is cheap on windows; basically
* it just subtracts from the stack pointer causing the OS to throw an
* exception if the stack pointer is set below the bottom of the stack.
*/
#ifdef HAVE_NO_SEH
__asm__ __volatile__ (
/*
* Construct an EXCEPTION_REGISTRATION to protect the
* call to __alloca
*/
"leal %[registration], %%edx" "\n\t"
"movl %%fs:0, %%eax" "\n\t"
"movl %%eax, 0x0(%%edx)" "\n\t" /* link */
"leal 1f, %%eax" "\n\t"
"movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
"movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
"movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
"movl %[error], 0x10(%%edx)" "\n\t" /* status */
/*
* Link the EXCEPTION_REGISTRATION on the chain
*/
"movl %%edx, %%fs:0" "\n\t"
/*
* Attempt a call to __alloca, to determine whether there's
* sufficient memory to be had.
*/
"movl %[size], %%eax" "\n\t"
"pushl %%eax" "\n\t"
"call __alloca" "\n\t"
/*
* Come here on a normal exit. Recover the EXCEPTION_REGISTRATION
* and store a TCL_OK status
*/
"movl %%fs:0, %%edx" "\n\t"
"movl %[ok], %%eax" "\n\t"
"movl %%eax, 0x10(%%edx)" "\n\t"
"jmp 2f" "\n"
/*
* Come here on an exception. Get the EXCEPTION_REGISTRATION
* that we previously put on the chain.
*/
"1:" "\t"
"movl %%fs:0, %%edx" "\n\t"
"movl 0x8(%%edx), %%edx" "\n\t"
/*
* Come here however we exited. Restore context from the
* EXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
"2:" "\t"
"movl 0xc(%%edx), %%esp" "\n\t"
"movl 0x8(%%edx), %%ebp" "\n\t"
"movl 0x0(%%edx), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
:
/* No outputs */
:
[registration] "m" (registration),
[ok] "i" (TCL_OK),
[error] "i" (TCL_ERROR),
[size] "i" (TCL_WIN_STACK_THRESHOLD)
:
"%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
);
retval = (registration.status == TCL_OK);
#else /* !HAVE_NO_SEH */
__try {
#ifdef HAVE_ALLOCA_GCC_INLINE
__asm__ __volatile__ (
"movl %0, %%eax" "\n\t"
"call __alloca" "\n\t"
:
: "i"(TCL_WIN_STACK_THRESHOLD)
: "%eax");
#else
alloca(TCL_WIN_STACK_THRESHOLD);
#endif /* HAVE_ALLOCA_GCC_INLINE */
retval = 1;
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif /* HAVE_NO_SEH */
return retval;
}
/*
*----------------------------------------------------------------------
*
* TclWinGetPlatform --
*
* This is a kludge that allows the test library to get access
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 |
tclWinProcs->getFileAttributesExProc =
(BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW");
tclWinProcs->createHardLinkProc =
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
"CreateHardLinkW");
FreeLibrary(hInstance);
}
}
} else {
tclWinProcs = &asciiProcs;
tclWinTCharEncoding = NULL;
if (tclWinProcs->getFileAttributesExProc == NULL) {
HINSTANCE hInstance = LoadLibraryA("kernel32");
if (hInstance != NULL) {
tclWinProcs->getFileAttributesExProc =
(BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA");
tclWinProcs->createHardLinkProc =
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
"CreateHardLinkA");
FreeLibrary(hInstance);
}
}
}
}
/*
*---------------------------------------------------------------------------
*
* TclWinResetInterfaceEncodings --
*
* Called during finalization to free up any encodings we use.
* The tclWinProcs-> look up table is still ok to use after
* this call, provided no encoding conversion is required.
*
* Results:
* None.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
void
TclWinResetInterfaceEncodings()
{
if (tclWinTCharEncoding != NULL) {
Tcl_FreeEncoding(tclWinTCharEncoding);
tclWinTCharEncoding = NULL;
}
}
/*
*---------------------------------------------------------------------------
*
* TclWinResetInterfaces --
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 |
tclWinProcs->getFileAttributesExProc =
(BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW");
tclWinProcs->createHardLinkProc =
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
"CreateHardLinkW");
tclWinProcs->findFirstFileExProc =
(HANDLE (WINAPI *)(CONST TCHAR*, UINT,
LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance,
"FindFirstFileExW");
tclWinProcs->getVolumeNameForVMPProc =
(BOOL (WINAPI *)(CONST TCHAR*, TCHAR*,
DWORD)) GetProcAddress(hInstance,
"GetVolumeNameForVolumeMountPointW");
FreeLibrary(hInstance);
}
hInstance = LoadLibraryA("advapi32");
if (hInstance != NULL) {
tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)(
LPCTSTR lpFileName,
SECURITY_INFORMATION RequestedInformation,
PSECURITY_DESCRIPTOR pSecurityDescriptor,
DWORD nLength, LPDWORD lpnLengthNeeded))
GetProcAddress(hInstance, "GetFileSecurityW");
tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) (
SECURITY_IMPERSONATION_LEVEL ImpersonationLevel))
GetProcAddress(hInstance, "ImpersonateSelf");
tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) (
HANDLE ThreadHandle, DWORD DesiredAccess,
BOOL OpenAsSelf, PHANDLE TokenHandle))
GetProcAddress(hInstance, "OpenThreadToken");
tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void))
GetProcAddress(hInstance, "RevertToSelf");
tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) (
PDWORD AccessMask, PGENERIC_MAPPING GenericMapping))
GetProcAddress(hInstance, "MapGenericMask");
tclWinProcs->accessCheckProc = (BOOL (WINAPI *)(
PSECURITY_DESCRIPTOR pSecurityDescriptor,
HANDLE ClientToken, DWORD DesiredAccess,
PGENERIC_MAPPING GenericMapping,
PPRIVILEGE_SET PrivilegeSet,
LPDWORD PrivilegeSetLength, LPDWORD GrantedAccess,
LPBOOL AccessStatus)) GetProcAddress(hInstance,
"AccessCheck");
FreeLibrary(hInstance);
}
}
} else {
tclWinProcs = &asciiProcs;
tclWinTCharEncoding = NULL;
if (tclWinProcs->getFileAttributesExProc == NULL) {
HINSTANCE hInstance = LoadLibraryA("kernel32");
if (hInstance != NULL) {
tclWinProcs->getFileAttributesExProc =
(BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExA");
tclWinProcs->createHardLinkProc =
(BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*,
LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
"CreateHardLinkA");
tclWinProcs->findFirstFileExProc =
(HANDLE (WINAPI *)(CONST TCHAR*, UINT,
LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance,
"FindFirstFileExA");
tclWinProcs->getLongPathNameProc = NULL;
tclWinProcs->getVolumeNameForVMPProc =
(BOOL (WINAPI *)(CONST TCHAR*, TCHAR*,
DWORD)) GetProcAddress(hInstance,
"GetVolumeNameForVolumeMountPointA");
FreeLibrary(hInstance);
}
}
}
}
/*
*---------------------------------------------------------------------------
*
* TclWinResetInterfaceEncodings --
*
* Called during finalization to free up any encodings we use.
* The tclWinProcs-> look up table is still ok to use after
* this call, provided no encoding conversion is required.
*
* We also clean up any memory allocated in our mount point
* map which is used to follow certain kinds of symlinks.
* That code should never be used once encodings are taken
* down.
*
* Results:
* None.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
void
TclWinResetInterfaceEncodings()
{
MountPointMap *dlIter, *dlIter2;
if (tclWinTCharEncoding != NULL) {
Tcl_FreeEncoding(tclWinTCharEncoding);
tclWinTCharEncoding = NULL;
}
/* Clean up the mount point map */
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
dlIter2 = dlIter->nextPtr;
ckfree((char*)dlIter->volumeName);
ckfree((char*)dlIter);
dlIter = dlIter2;
}
Tcl_MutexUnlock(&mountPointMap);
}
/*
*---------------------------------------------------------------------------
*
* TclWinResetInterfaces --
*
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
*---------------------------------------------------------------------------
*/
void
TclWinResetInterfaces()
{
tclWinProcs = &asciiProcs;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_WinUtfToTChar, Tcl_WinTCharToUtf --
*
* Convert between UTF-8 and Unicode when running Windows NT or
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 |
*---------------------------------------------------------------------------
*/
void
TclWinResetInterfaces()
{
tclWinProcs = &asciiProcs;
}
/*
*--------------------------------------------------------------------
*
* TclWinDriveLetterForVolMountPoint
*
* Unfortunately, Windows provides no easy way at all to get hold
* of the drive letter for a volume mount point, but we need that
* information to understand paths correctly. So, we have to
* build an associated array to find these correctly, and allow
* quick and easy lookup from volume mount points to drive letters.
*
* We assume here that we are running on a system for which the wide
* character interfaces are used, which is valid for Win 2000 and WinXP
* which are the only systems on which this function will ever be called.
*
* Result: the drive letter, or -1 if no drive letter corresponds to
* the given mount point.
*
*--------------------------------------------------------------------
*/
char
TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint)
{
MountPointMap *dlIter, *dlPtr2;
WCHAR Target[55]; /* Target of mount at mount point */
WCHAR drive[4] = { L'A', L':', L'\\', L'\0' };
/*
* Detect the volume mounted there. Unfortunately, there is no
* simple way to map a unique volume name to a DOS drive letter.
* So, we have to build an associative array.
*/
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
/*
* We need to check whether this information is
* still valid, since either the user or various
* programs could have adjusted the mount points on
* the fly.
*/
drive[0] = L'A' + (dlIter->driveLetter - 'A');
/* Try to read the volume mount point and see where it points */
if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive,
(TCHAR*)Target, 55) != 0) {
if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
/* Nothing has changed */
Tcl_MutexUnlock(&mountPointMap);
return dlIter->driveLetter;
}
}
/*
* If we reach here, unfortunately, this mount point is
* no longer valid at all
*/
if (driveLetterLookup == dlIter) {
dlPtr2 = dlIter;
driveLetterLookup = dlIter->nextPtr;
} else {
for (dlPtr2 = driveLetterLookup;
dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) {
if (dlPtr2->nextPtr == dlIter) {
dlPtr2->nextPtr = dlIter->nextPtr;
dlPtr2 = dlIter;
break;
}
}
}
/* Now dlPtr2 points to the structure to free */
ckfree((char*)dlPtr2->volumeName);
ckfree((char*)dlPtr2);
/*
* Restart the loop --- we could try to be clever
* and continue half way through, but the logic is a
* bit messy, so it's cleanest just to restart
*/
dlIter = driveLetterLookup;
continue;
}
dlIter = dlIter->nextPtr;
}
/* We couldn't find it, so we must iterate over the letters */
for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) {
/* Try to read the volume mount point and see where it points */
if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive,
(TCHAR*)Target, 55) != 0) {
int alreadyStored = 0;
for (dlIter = driveLetterLookup; dlIter != NULL;
dlIter = dlIter->nextPtr) {
if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) {
alreadyStored = 1;
break;
}
}
if (!alreadyStored) {
dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap));
dlPtr2->volumeName = TclNativeDupInternalRep(Target);
dlPtr2->driveLetter = 'A' + (drive[0] - L'A');
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
}
}
}
/* Try again */
for (dlIter = driveLetterLookup; dlIter != NULL;
dlIter = dlIter->nextPtr) {
if (wcscmp(dlIter->volumeName, mountPoint) == 0) {
Tcl_MutexUnlock(&mountPointMap);
return dlIter->driveLetter;
}
}
/*
* The volume doesn't appear to correspond to a drive letter -- we
* remember that fact and store '-1' so we don't have to look it
* up each time.
*/
dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap));
dlPtr2->volumeName = TclNativeDupInternalRep((ClientData)mountPoint);
dlPtr2->driveLetter = -1;
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
Tcl_MutexUnlock(&mountPointMap);
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_WinUtfToTChar, Tcl_WinTCharToUtf --
*
* Convert between UTF-8 and Unicode when running Windows NT or
|
| ︙ | ︙ | |||
676 677 678 679 680 681 682 |
* platform-specific string length. */
Tcl_DString *dsPtr; /* Uninitialized or free DString in which
* the converted string is stored. */
{
return Tcl_ExternalToUtfDString(tclWinTCharEncoding,
(CONST char *) string, len, dsPtr);
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 |
* platform-specific string length. */
Tcl_DString *dsPtr; /* Uninitialized or free DString in which
* the converted string is stored. */
{
return Tcl_ExternalToUtfDString(tclWinTCharEncoding,
(CONST char *) string, len, dsPtr);
}
/*
*------------------------------------------------------------------------
*
* TclWinCPUID --
*
* Get CPU ID information on an Intel box under Windows
*
* Results:
* Returns TCL_OK if successful, TCL_ERROR if CPUID is not
* supported or fails.
*
* Side effects:
* If successful, stores EAX, EBX, ECX and EDX registers after
* the CPUID instruction in the four integers designated by 'regsPtr'
*
*----------------------------------------------------------------------
*/
int
TclWinCPUID( unsigned int index, /* Which CPUID value to retrieve */
unsigned int * regsPtr ) /* Registers after the CPUID */
{
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
#endif
int status = TCL_ERROR;
#if defined(__GNUC__) && !defined(_WIN64)
/*
* Execute the CPUID instruction with the given index, and
* store results off 'regPtr'.
*/
__asm__ __volatile__ (
/*
* Construct an EXCEPTION_REGISTRATION to protect the
* CPUID instruction (early 486's don't have CPUID)
*/
"leal %[registration], %%edx" "\n\t"
"movl %%fs:0, %%eax" "\n\t"
"movl %%eax, 0x0(%%edx)" "\n\t" /* link */
"leal 1f, %%eax" "\n\t"
"movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
"movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
"movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
"movl %[error], 0x10(%%edx)" "\n\t" /* status */
/*
* Link the EXCEPTION_REGISTRATION on the chain
*/
"movl %%edx, %%fs:0" "\n\t"
/*
* Do the CPUID instruction, and save the results in
* the 'regsPtr' area
*/
"movl %[rptr], %%edi" "\n\t"
"movl %[index], %%eax" "\n\t"
"cpuid" "\n\t"
"movl %%eax, 0x0(%%edi)" "\n\t"
"movl %%ebx, 0x4(%%edi)" "\n\t"
"movl %%ecx, 0x8(%%edi)" "\n\t"
"movl %%edx, 0xc(%%edi)" "\n\t"
/*
* Come here on a normal exit. Recover the EXCEPTION_REGISTRATION
* and store a TCL_OK status
*/
"movl %%fs:0, %%edx" "\n\t"
"movl %[ok], %%eax" "\n\t"
"movl %%eax, 0x10(%%edx)" "\n\t"
"jmp 2f" "\n"
/*
* Come here on an exception. Get the EXCEPTION_REGISTRATION
* that we previously put on the chain.
*/
"1:" "\t"
"movl %%fs:0, %%edx" "\n\t"
"movl 0x8(%%edx), %%edx" "\n\t"
/*
* Come here however we exited. Restore context from the
* EXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
"2:" "\t"
"movl 0xc(%%edx), %%esp" "\n\t"
"movl 0x8(%%edx), %%ebp" "\n\t"
"movl 0x0(%%edx), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
:
/* No outputs */
:
[index] "m" (index),
[rptr] "m" (regsPtr),
[registration] "m" (registration),
[ok] "i" (TCL_OK),
[error] "i" (TCL_ERROR)
:
"%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" );
status = registration.status;
#elif defined(_MSC_VER) && !defined(_WIN64)
/* Define a structure in the stack frame to hold the registers */
struct {
DWORD dw0;
DWORD dw1;
DWORD dw2;
DWORD dw3;
} regs;
regs.dw0 = index;
/* Execute the CPUID instruction and save regs in the stack frame */
_try {
_asm {
push ebx
push ecx
push edx
mov eax, regs.dw0
cpuid
mov regs.dw0, eax
mov regs.dw1, ebx
mov regs.dw2, ecx
mov regs.dw3, edx
pop edx
pop ecx
pop ebx
}
/* Copy regs back out to the caller */
regsPtr[0]=regs.dw0;
regsPtr[1]=regs.dw1;
regsPtr[2]=regs.dw2;
regsPtr[3]=regs.dw3;
status = TCL_OK;
} __except( EXCEPTION_EXECUTE_HANDLER ) {
}
#else
/* Don't know how to do assembly code for
* this compiler and/or architecture */
#endif
return status;
}
|
Changes to win/tclWinChan.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclWinChan.c * * Channel drivers for Windows channels based on files, command * pipes and TCP sockets. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclWinChan.c * * Channel drivers for Windows channels based on files, command * pipes and TCP sockets. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinChan.c,v 1.30.2.5 2006/08/30 17:53:28 hobbs Exp $ */ #include "tclWinInt.h" #include "tclIO.h" /* * State flags used in the info structures below. |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 | long offset, int mode, int *errorCode)); static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCode)); static void FileSetupProc _ANSI_ARGS_((ClientData clientData, int flags)); static void FileWatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); | | > > | | > | | > > > > > | | > > > > > > > | < < < > | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
long offset, int mode, int *errorCode));
static Tcl_WideInt FileWideSeekProc _ANSI_ARGS_((ClientData instanceData,
Tcl_WideInt offset, int mode, int *errorCode));
static void FileSetupProc _ANSI_ARGS_((ClientData clientData,
int flags));
static void FileWatchProc _ANSI_ARGS_((ClientData instanceData,
int mask));
static void FileThreadActionProc _ANSI_ARGS_ ((
ClientData instanceData, int action));
static DWORD FileGetType _ANSI_ARGS_((HANDLE handle));
/*
* This structure describes the channel type structure for file based IO.
*/
static Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
FileCloseProc, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
FileSeekProc, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
FileWatchProc, /* Set up the notifier to watch the channel. */
FileGetHandleProc, /* Get an OS handle from channel. */
NULL, /* close2proc. */
FileBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
FileWideSeekProc, /* Wide seek proc. */
FileThreadActionProc, /* Thread action proc. */
};
#ifdef HAVE_NO_SEH
/*
* Unlike Borland and Microsoft, we don't register exception handlers
* by pushing registration records onto the runtime stack. Instead, we
* register them by creating an EXCEPTION_REGISTRATION within the activation
* record.
*/
typedef struct EXCEPTION_REGISTRATION {
struct EXCEPTION_REGISTRATION* link;
EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*,
struct _CONTEXT*, void* );
void* ebp;
void* esp;
int status;
} EXCEPTION_REGISTRATION;
#endif
/*
*----------------------------------------------------------------------
*
* FileInit --
*
* This function creates the window used to simulate file events.
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 393 394 395 396 397 398 399 |
static int
FileCloseProc(instanceData, interp)
ClientData instanceData; /* Pointer to FileInfo structure. */
Tcl_Interp *interp; /* Not used. */
{
FileInfo *fileInfoPtr = (FileInfo *) instanceData;
int errorCode = 0;
/*
* Remove the file from the watch list.
*/
FileWatchProc(instanceData, 0);
| > > | 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 |
static int
FileCloseProc(instanceData, interp)
ClientData instanceData; /* Pointer to FileInfo structure. */
Tcl_Interp *interp; /* Not used. */
{
FileInfo *fileInfoPtr = (FileInfo *) instanceData;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr;
int errorCode = 0;
/*
* Remove the file from the watch list.
*/
FileWatchProc(instanceData, 0);
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
&& (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) {
if (CloseHandle(fileInfoPtr->handle) == FALSE) {
TclWinConvertError(GetLastError());
errorCode = errno;
}
}
ckfree((char *)fileInfoPtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
| > > > > > > > > > > > > > > > > > | 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
&& (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) {
if (CloseHandle(fileInfoPtr->handle) == FALSE) {
TclWinConvertError(GetLastError());
errorCode = errno;
}
}
/*
* See if this FileInfo* is still on the thread local list.
*/
tsdPtr = TCL_TSD_INIT(&dataKey);
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr == fileInfoPtr) {
/*
* This channel exists on the thread local list. It should
* have been removed by an earlier Thread Action call,
* but do that now since just deallocating fileInfoPtr would
* leave an deallocated pointer on the thread local list.
*/
FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE);
break;
}
}
ckfree((char *)fileInfoPtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
748 749 750 751 752 753 754 |
int mode; /* POSIX mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel channel = 0;
int channelPermissions;
| | < | 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 |
int mode; /* POSIX mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel channel = 0;
int channelPermissions;
DWORD accessMode, createMode, shareMode, flags;
CONST TCHAR *nativeName;
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL;
TclFile writeFile = NULL;
nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr);
if (nativeName == NULL) {
|
| ︙ | ︙ | |||
849 850 851 852 853 854 855 |
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
| < < < < < < < < < < < < < < < < < < < < | | 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 |
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
channel = NULL;
switch ( FileGetType(handle) ) {
case FILE_TYPE_SERIAL:
/*
* Reopen channel for OVERLAPPED operation
* Normally this shouldn't fail, because the channel exists
*/
handle = TclWinSerialReopen(handle, nativeName, accessMode);
if (handle == INVALID_HANDLE_VALUE) {
|
| ︙ | ︙ | |||
950 951 952 953 954 955 956 957 958 959 960 |
Tcl_Channel
Tcl_MakeFileChannel(rawHandle, mode)
ClientData rawHandle; /* OS level handle */
int mode; /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
char channelName[16 + TCL_INTEGER_SPACE];
Tcl_Channel channel = NULL;
HANDLE handle = (HANDLE) rawHandle;
HANDLE dupedHandle;
| > > > < < < < < < < < < < < < < < < < < < < < < < < < < | | 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 |
Tcl_Channel
Tcl_MakeFileChannel(rawHandle, mode)
ClientData rawHandle; /* OS level handle */
int mode; /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
#endif
char channelName[16 + TCL_INTEGER_SPACE];
Tcl_Channel channel = NULL;
HANDLE handle = (HANDLE) rawHandle;
HANDLE dupedHandle;
TclFile readFile = NULL;
TclFile writeFile = NULL;
BOOL result;
if (mode == 0) {
return NULL;
}
switch (FileGetType(handle))
{
case FILE_TYPE_SERIAL:
channel = TclWinOpenSerialChannel(handle, channelName, mode);
break;
case FILE_TYPE_CONSOLE:
channel = TclWinOpenConsoleChannel(handle, channelName, mode);
break;
|
| ︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 | } /* * Use structured exception handling (Win32 SEH) to protect the close * of this duped handle which might throw EXCEPTION_INVALID_HANDLE. */ | > | > > > > > > > > > > > | | | < < < < < | > > < > < < < < < < < | > | < < < > | | | > > | | > | > | | | > | > > | < > > > > | < < | | | < | < | < < < < < < | > > | < < < > > > | < | < < > > | > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < | 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 |
}
/*
* Use structured exception handling (Win32 SEH) to protect the close
* of this duped handle which might throw EXCEPTION_INVALID_HANDLE.
*/
result = 0;
#ifndef HAVE_NO_SEH
__try {
CloseHandle(dupedHandle);
result = 1;
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#else
/*
* Don't have SEH available, do things the hard way.
* Note that this needs to be one block of asm, to avoid stack
* imbalance; also, it is illegal for one asm block to contain
* a jump to another.
*/
__asm__ __volatile__ (
/*
* Pick up parameters before messing with the stack
*/
"movl %[dupedHandle], %%ebx" "\n\t"
/*
* Construct an EXCEPTION_REGISTRATION to protect the
* call to CloseHandle
*/
"leal %[registration], %%edx" "\n\t"
"movl %%fs:0, %%eax" "\n\t"
"movl %%eax, 0x0(%%edx)" "\n\t" /* link */
"leal 1f, %%eax" "\n\t"
"movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
"movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
"movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
"movl $0, 0x10(%%edx)" "\n\t" /* status */
/* Link the EXCEPTION_REGISTRATION on the chain */
"movl %%edx, %%fs:0" "\n\t"
/* Call CloseHandle( dupedHandle ) */
"pushl %%ebx" "\n\t"
"call _CloseHandle@4" "\n\t"
/*
* Come here on normal exit. Recover the EXCEPTION_REGISTRATION
* and put a TRUE status return into it.
*/
"movl %%fs:0, %%edx" "\n\t"
"movl $1, %%eax" "\n\t"
"movl %%eax, 0x10(%%edx)" "\n\t"
"jmp 2f" "\n"
/*
* Come here on an exception. Recover the EXCEPTION_REGISTRATION
*/
"1:" "\t"
"movl %%fs:0, %%edx" "\n\t"
"movl 0x8(%%edx), %%edx" "\n\t"
/*
* Come here however we exited. Restore context from the
* EXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
"2:" "\t"
"movl 0xc(%%edx), %%esp" "\n\t"
"movl 0x8(%%edx), %%ebp" "\n\t"
"movl 0x0(%%edx), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
:
/* No outputs */
:
[registration] "m" (registration),
[dupedHandle] "m" (dupedHandle)
:
"%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"
);
result = registration.status;
#endif
if (result == FALSE) {
return NULL;
}
/* Fall through, the handle is valid. */
/*
* Create the undefined channel, anyways, because we know the handle
* is valid to something.
*/
channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
}
return channel;
}
/*
*----------------------------------------------------------------------
*
* TclpGetDefaultStdChannel --
*
* Constructs a channel for the specified standard OS handle.
|
| ︙ | ︙ | |||
1268 1269 1270 1271 1272 1273 1274 |
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
return (permissions == infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
| > > > > | < | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 |
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
return (permissions == infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
/* TIP #218. Removed the code inserting the new structure
* into the global list. This is now handled in the thread
* action callbacks, and only there.
*/
infoPtr->nextPtr = NULL;
infoPtr->validMask = permissions;
infoPtr->watchMask = 0;
infoPtr->flags = appendMode;
infoPtr->handle = handle;
infoPtr->dirty = 0;
wsprintfA(channelName, "file%lx", (int) infoPtr);
|
| ︙ | ︙ | |||
1338 1339 1340 1341 1342 1343 1344 |
}
}
}
/*
*----------------------------------------------------------------------
*
| | | < | | < | | < | > > > > > | | < < < < < | | | | | | | | | | | | | | | | | | > > | | < | < > | | < < | > > | | | > > > > > | > > > | > > > | < | > | < > | 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 |
}
}
}
/*
*----------------------------------------------------------------------
*
* FileThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
FileThreadActionProc (instanceData, action)
ClientData instanceData;
int action;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileInfo *infoPtr = (FileInfo *) instanceData;
if (action == TCL_CHANNEL_THREAD_INSERT) {
infoPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = infoPtr;
} else {
FileInfo **nextPtrPtr;
int removed = 0;
for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == infoPtr) {
(*nextPtrPtr) = infoPtr->nextPtr;
removed = 1;
break;
}
}
/*
* This could happen if the channel was created in one thread
* and then moved to another without updating the thread
* local data in each thread.
*/
if (!removed) {
panic("file info ptr not on thread channel list");
}
}
}
/*
*----------------------------------------------------------------------
*
* FileGetType --
*
* Given a file handle, return its type
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
DWORD
FileGetType(handle)
HANDLE handle; /* Opened file handle */
{
DWORD type;
DWORD consoleParams;
DCB dcb;
type = GetFileType(handle);
/*
* If the file is a character device, we need to try to figure out
* whether it is a serial port, a console, or something else. We
* test for the console case first because this is more common.
*/
if (type == FILE_TYPE_CHAR || (type == FILE_TYPE_UNKNOWN && !GetLastError())) {
if (GetConsoleMode(handle, &consoleParams)) {
type = FILE_TYPE_CONSOLE;
} else {
dcb.DCBlength = sizeof( DCB ) ;
if (GetCommState(handle, &dcb)) {
type = FILE_TYPE_SERIAL;
}
}
}
return type;
}
|
Changes to win/tclWinConsole.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclWinConsole.c -- * * This file implements the Windows-specific console functions, * and the "console" channel driver. * * Copyright (c) 1999 by Scriptics Corp. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclWinConsole.c -- * * This file implements the Windows-specific console functions, * and the "console" channel driver. * * Copyright (c) 1999 by Scriptics Corp. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinConsole.c,v 1.11.2.3 2006/03/28 21:02:37 hobbs Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> |
| ︙ | ︙ | |||
144 145 146 147 148 149 150 | static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); | | > > > | > > | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
static void ConsoleCheckProc(ClientData clientData, int flags);
static int ConsoleCloseProc(ClientData instanceData,
Tcl_Interp *interp);
static int ConsoleEventProc(Tcl_Event *evPtr, int flags);
static void ConsoleExitHandler(ClientData clientData);
static int ConsoleGetHandleProc(ClientData instanceData,
int direction, ClientData *handlePtr);
static void ConsoleInit(void);
static int ConsoleInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
static int ConsoleOutputProc(ClientData instanceData,
CONST char *buf, int toWrite, int *errorCode);
static DWORD WINAPI ConsoleReaderThread(LPVOID arg);
static void ConsoleSetupProc(ClientData clientData, int flags);
static void ConsoleWatchProc(ClientData instanceData, int mask);
static DWORD WINAPI ConsoleWriterThread(LPVOID arg);
static void ProcExitHandler(ClientData clientData);
static int WaitForRead(ConsoleInfo *infoPtr, int blocking);
static void ConsoleThreadActionProc _ANSI_ARGS_ ((
ClientData instanceData, int action));
/*
* This structure describes the channel type structure for command console
* based IO.
*/
static Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
ConsoleCloseProc, /* Close proc. */
ConsoleInputProc, /* Input proc. */
ConsoleOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
ConsoleWatchProc, /* Set up notifier to watch the channel. */
ConsoleGetHandleProc, /* Get an OS handle from channel. */
NULL, /* close2proc. */
ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
ConsoleThreadActionProc, /* thread action proc */
};
/*
*----------------------------------------------------------------------
*
* ConsoleInit --
*
* This function initializes the static variables for this file.
*
* Results:
* None.
*
* Side effects:
* Creates a new event source.
*
*----------------------------------------------------------------------
*/
static void
ConsoleInit()
{
ThreadSpecificData *tsdPtr;
/*
* Check the initialized flag first, then check again in the mutex.
* This is a speed enhancement.
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 |
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->firstConsolePtr = NULL;
Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
}
| < | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->firstConsolePtr = NULL;
Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
}
}
/*
*----------------------------------------------------------------------
*
* ConsoleExitHandler --
*
|
| ︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 | /* * Alert the foreground thread. Note that we need to treat this like * a critical section so the foreground thread does not terminate * this thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&consoleMutex); | > > | > | 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 |
/*
* Alert the foreground thread. Note that we need to treat this like
* a critical section so the foreground thread does not terminate
* this thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&consoleMutex);
if (infoPtr->threadId != NULL) {
/* TIP #218. When in flight ignore the event, no one will receive it anyway */
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&consoleMutex);
}
return 0;
}
/*
|
| ︙ | ︙ | |||
1252 1253 1254 1255 1256 1257 1258 | /* * Alert the foreground thread. Note that we need to treat this like * a critical section so the foreground thread does not terminate * this thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&consoleMutex); | > > | > | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 |
/*
* Alert the foreground thread. Note that we need to treat this like
* a critical section so the foreground thread does not terminate
* this thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&consoleMutex);
if (infoPtr->threadId != NULL) {
/* TIP #218. When in flight ignore the event, no one will receive it anyway */
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&consoleMutex);
}
return 0;
}
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 |
TclWinOpenConsoleChannel(handle, channelName, permissions)
HANDLE handle;
char *channelName;
int permissions;
{
char encoding[4 + TCL_INTEGER_SPACE];
ConsoleInfo *infoPtr;
| < | > > > < < | 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 |
TclWinOpenConsoleChannel(handle, channelName, permissions)
HANDLE handle;
char *channelName;
int permissions;
{
char encoding[4 + TCL_INTEGER_SPACE];
ConsoleInfo *infoPtr;
DWORD id, modes;
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
wsprintfA(encoding, "cp%d", GetConsoleCP());
infoPtr->threadId = Tcl_GetCurrentThread();
/*
* Use the pointer for the name of the result channel.
* This keeps the channel names unique, since some may share
* handles (stdin/stdout/stderr for instance).
*/
wsprintfA(channelName, "file%lx", (int) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
(ClientData) infoPtr, permissions);
if (permissions & TCL_READABLE) {
/*
* Make sure the console input buffer is ready for only character
* input notifications and the buffer is set for line buffering.
* IOW, we only want to catch when complete lines are ready for
* reading.
*/
|
| ︙ | ︙ | |||
1357 1358 1359 1360 1361 1362 1363 |
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
return infoPtr->channel;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 |
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
return infoPtr->channel;
}
/*
*----------------------------------------------------------------------
*
* ConsoleThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
ConsoleThreadActionProc (instanceData, action)
ClientData instanceData;
int action;
{
ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
/* We do not access firstConsolePtr in the thread structures. This is
* not for all serials managed by the thread, but only those we are
* watching. Removal of the filevent handlers before transfer thus
* takes care of this structure.
*/
Tcl_MutexLock(&consoleMutex);
if (action == TCL_CHANNEL_THREAD_INSERT) {
/* We can't copy the thread information from the channel when
* the channel is created. At this time the channel back
* pointer has not been set yet. However in that case the
* threadId has already been set by TclpCreateCommandChannel
* itself, so the structure is still good.
*/
ConsoleInit ();
if (infoPtr->channel != NULL) {
infoPtr->threadId = Tcl_GetChannelThread (infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&consoleMutex);
}
|
Changes to win/tclWinDde.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclWinDde.c -- * * This file provides procedures that implement the "send" * command, allowing commands to be passed from interpreter * to interpreter. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | /* * tclWinDde.c -- * * This file provides procedures that implement the "send" * command, allowing commands to be passed from interpreter * to interpreter. * * Copyright (c) 1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinDde.c,v 1.13.2.7 2006/04/05 20:50:46 dgp Exp $ */ #include "tclPort.h" #include <dde.h> #include <ddeml.h> #include <tchar.h> /* * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the * Registry_Init declaration is in the source file itself, which is only * accessed when we are building a library. */ |
| ︙ | ︙ | |||
65 66 67 68 69 70 71 | * The Mutex ddeMutex guards access to the ddeInstance. */ static HSZ ddeServiceGlobal = 0; static DWORD ddeInstance; /* The application instance handle given * to us by DdeInitialize. */ static int ddeIsServer = 0; | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | * The Mutex ddeMutex guards access to the ddeInstance. */ static HSZ ddeServiceGlobal = 0; static DWORD ddeInstance; /* The application instance handle given * to us by DdeInitialize. */ static int ddeIsServer = 0; #define TCL_DDE_VERSION "1.2.4" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME "TclEval" TCL_DECLARE_MUTEX(ddeMutex) /* * Forward declarations for procedures defined later in this file. |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 94 95 96 97 98 99 100 | static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp, char *name, HCONV *ddeConvPtr)); static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2)); static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp)); int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */ Tcl_Interp *interp, /* The interp we are sending from */ int objc, /* Number of arguments */ Tcl_Obj *CONST objv[]); /* The arguments */ EXTERN int Dde_Init(Tcl_Interp *interp); | > > > > | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp, char *name, HCONV *ddeConvPtr)); static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2)); static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp)); static int DdeGetServicesList _ANSI_ARGS_(( Tcl_Interp *interp, char *serviceName, char *topicName)); int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */ Tcl_Interp *interp, /* The interp we are sending from */ int objc, /* Number of arguments */ Tcl_Obj *CONST objv[]); /* The arguments */ EXTERN int Dde_Init(Tcl_Interp *interp); |
| ︙ | ︙ | |||
287 288 289 290 291 292 293 |
/*
* We have found a unique name. Now add it to the registry.
*/
riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
| | | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
/*
* We have found a unique name. Now add it to the registry.
*/
riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
riPtr->name = ckalloc((unsigned int) strlen(name) + 1);
riPtr->nextPtr = tsdPtr->interpListPtr;
tsdPtr->interpListPtr = riPtr;
strcpy(riPtr->name, name);
Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
(ClientData) riPtr, DeleteProc);
if (Tcl_IsSafe(interp)) {
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
*ddeConvPtr = ddeConv;
return TCL_OK;
}
/*
*--------------------------------------------------------------
*
* SetDdeError --
*
* Sets the interp result to a cogent error message
* describing the last DDE error.
*
* Results:
* None.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
*ddeConvPtr = ddeConv;
return TCL_OK;
}
/*
*--------------------------------------------------------------
*
* DdeGetServicesList --
*
* This procedure obtains the list of DDE services.
*
* The functions between here and this procedure are all
* involved with handling the DDE callbacks for this.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Sets the services list into the interp result.
*
*--------------------------------------------------------------
*/
typedef struct ddeEnumServices {
Tcl_Interp *interp;
int result;
ATOM service;
ATOM topic;
HWND hwnd;
} ddeEnumServices;
LRESULT CALLBACK
DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam);
static LRESULT
DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam);
static int
DdeCreateClient(ddeEnumServices *es)
{
WNDCLASSEX wc;
static const char *szDdeClientClassName = "TclEval client class";
static const char *szDdeClientWindowName = "TclEval client window";
memset(&wc, 0, sizeof(wc));
wc.cbSize = sizeof(wc);
wc.lpfnWndProc = DdeClientWindowProc;
wc.lpszClassName = szDdeClientClassName;
wc.cbWndExtra = sizeof(ddeEnumServices*);
/* register and create the callback window */
RegisterClassEx(&wc);
es->hwnd = CreateWindowEx(0, szDdeClientClassName,
szDdeClientWindowName,
WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL,
(LPVOID)es);
return TCL_OK;
}
LRESULT CALLBACK
DdeClientWindowProc(HWND hwnd, UINT uMsg, WPARAM wParam, LPARAM lParam)
{
LRESULT lr = 0L;
switch (uMsg) {
case WM_CREATE: {
LPCREATESTRUCT lpcs = (LPCREATESTRUCT)lParam;
ddeEnumServices *es;
es = (ddeEnumServices*)lpcs->lpCreateParams;
#ifdef _WIN64
SetWindowLongPtr(hwnd, GWLP_USERDATA, (long)es);
#else
SetWindowLong(hwnd, GWL_USERDATA, (long)es);
#endif
break;
}
case WM_DDE_ACK:
lr = DdeServicesOnAck(hwnd, wParam, lParam);
break;
default:
lr = DefWindowProc(hwnd, uMsg, wParam, lParam);
}
return lr;
}
static LRESULT
DdeServicesOnAck(HWND hwnd, WPARAM wParam, LPARAM lParam)
{
HWND hwndRemote = (HWND)wParam;
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
ddeEnumServices *es;
TCHAR sz[255];
#ifdef _WIN64
es = (ddeEnumServices *)GetWindowLongPtr(hwnd, GWLP_USERDATA);
#else
es = (ddeEnumServices *)GetWindowLong(hwnd, GWL_USERDATA);
#endif
if ((es->service == (ATOM)NULL || es->service == service)
&& (es->topic == (ATOM)NULL || es->topic == topic)) {
Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
GlobalGetAtomName(service, sz, 255);
Tcl_ListObjAppendElement(es->interp, matchPtr,
Tcl_NewStringObj(sz, -1));
GlobalGetAtomName(topic, sz, 255);
Tcl_ListObjAppendElement(es->interp, matchPtr,
Tcl_NewStringObj(sz, -1));
/* Adding the hwnd as a third list element provides a unique
* identifier in the case of multiple servers with the name
* application and topic names.
*/
/* Needs a TIP though
* Tcl_ListObjAppendElement(es->interp, matchPtr,
* Tcl_NewLongObj((long)hwndRemote));
*/
Tcl_ListObjAppendElement(es->interp,
Tcl_GetObjResult(es->interp), matchPtr);
}
/* tell the server we are no longer interested */
PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
return 0L;
}
static BOOL CALLBACK
DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam)
{
LRESULT dwResult = 0;
ddeEnumServices *es = (ddeEnumServices *)lParam;
SendMessageTimeout(hwndTarget, WM_DDE_INITIATE,
(WPARAM)es->hwnd,
MAKELONG(es->service, es->topic),
SMTO_ABORTIFHUNG, 1000, &dwResult);
return TRUE;
}
static int
DdeGetServicesList(Tcl_Interp *interp, char *serviceName, char *topicName)
{
ddeEnumServices es;
int r = TCL_OK;
es.interp = interp;
es.result = TCL_OK;
es.service = (serviceName == NULL)
? (ATOM)NULL : GlobalAddAtom(serviceName);
es.topic = (topicName == NULL)
? (ATOM)NULL : GlobalAddAtom(topicName);
Tcl_ResetResult(interp); /* our list is to be appended to result. */
DdeCreateClient(&es);
EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es);
if (IsWindow(es.hwnd))
DestroyWindow(es.hwnd);
if (es.service != (ATOM)NULL)
GlobalDeleteAtom(es.service);
if (es.topic != (ATOM)NULL)
GlobalDeleteAtom(es.topic);
return es.result;
}
/*
*--------------------------------------------------------------
*
* SetDdeError --
*
* Sets the interp result to a cogent error message
* describing the last DDE error.
*
* Results:
* None.
|
| ︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 |
result = TCL_ERROR;
}
}
break;
}
case DDE_SERVICES: {
| < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 |
result = TCL_ERROR;
}
}
break;
}
case DDE_SERVICES: {
result = DdeGetServicesList(interp, serviceName, topicName);
break;
}
case DDE_EVAL: {
if (serviceName == NULL) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"invalid service name \"\"", -1);
goto errorNoResult;
|
| ︙ | ︙ |
Changes to win/tclWinFCmd.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclWinFCmd.c * * This file implements the Windows specific portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclWinFCmd.c * * This file implements the Windows specific portion of file manipulation * subcommands of the "file" command. * * Copyright (c) 1996-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinFCmd.c,v 1.35.2.5 2006/08/30 17:48:48 hobbs Exp $ */ #include "tclWinInt.h" /* * The following constants specify the type of callback when * TraverseWinTree() calls the traverseProc() |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileLongName, CannotSetAttribute},
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileShortName, CannotSetAttribute},
{GetWinFileAttributes, SetWinFileAttributes}};
| | | > > > > > | | > > > > > > > | | < | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileLongName, CannotSetAttribute},
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileShortName, CannotSetAttribute},
{GetWinFileAttributes, SetWinFileAttributes}};
#ifdef HAVE_NO_SEH
/*
* Unlike Borland and Microsoft, we don't register exception handlers
* by pushing registration records onto the runtime stack. Instead, we
* register them by creating an EXCEPTION_REGISTRATION within the activation
* record.
*/
typedef struct EXCEPTION_REGISTRATION {
struct EXCEPTION_REGISTRATION* link;
EXCEPTION_DISPOSITION (*handler)( struct _EXCEPTION_RECORD*, void*,
struct _CONTEXT*, void* );
void* ebp;
void* esp;
int status;
} EXCEPTION_REGISTRATION;
#endif
/*
* Prototype for the TraverseWinTree callback function.
*/
typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr,
int type, Tcl_DString *errorPtr);
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
static int
DoRenameFile(
CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
CONST TCHAR *nativeDst) /* New pathname for file or directory
* (native). */
{
DWORD srcAttr, dstAttr;
int retval = -1;
/*
* The MoveFile API acts differently under Win95/98 and NT
* WRT NULL and "". Avoid passing these values.
*/
if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
nativeDst == NULL || nativeDst[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
/*
* The MoveFile API would throw an exception under NT
* if one of the arguments is a char block device.
*/
| > > > | < < < < < < < < < < < < < < < < < > > | > > > > > > > > > | | | | > > > > > | | | | | > > | > | > | > | < < | | > | | < < > > > > | < < < | | > | | < | > | > > > | | < > > | > > > > > > > > > > > > > > > > > > > > > > | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
static int
DoRenameFile(
CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
CONST TCHAR *nativeDst) /* New pathname for file or directory
* (native). */
{
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
#endif
DWORD srcAttr, dstAttr;
int retval = -1;
/*
* The MoveFile API acts differently under Win95/98 and NT
* WRT NULL and "". Avoid passing these values.
*/
if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
nativeDst == NULL || nativeDst[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
/*
* The MoveFile API would throw an exception under NT
* if one of the arguments is a char block device.
*/
#ifndef HAVE_NO_SEH
__try {
if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
retval = TCL_OK;
}
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#else
/*
* Don't have SEH available, do things the hard way.
* Note that this needs to be one block of asm, to avoid stack
* imbalance; also, it is illegal for one asm block to contain
* a jump to another.
*/
__asm__ __volatile__ (
/*
* Pick up params before messing with the stack */
"movl %[nativeDst], %%ebx" "\n\t"
"movl %[nativeSrc], %%ecx" "\n\t"
/*
* Construct an EXCEPTION_REGISTRATION to protect the
* call to MoveFile
*/
"leal %[registration], %%edx" "\n\t"
"movl %%fs:0, %%eax" "\n\t"
"movl %%eax, 0x0(%%edx)" "\n\t" /* link */
"leal 1f, %%eax" "\n\t"
"movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
"movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
"movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
"movl $0, 0x10(%%edx)" "\n\t" /* status */
/* Link the EXCEPTION_REGISTRATION on the chain */
"movl %%edx, %%fs:0" "\n\t"
/* Call MoveFile( nativeSrc, nativeDst ) */
"pushl %%ebx" "\n\t"
"pushl %%ecx" "\n\t"
"movl %[moveFile], %%eax" "\n\t"
"call *%%eax" "\n\t"
/*
* Come here on normal exit. Recover the EXCEPTION_REGISTRATION
* and put the status return from MoveFile into it.
*/
"movl %%fs:0, %%edx" "\n\t"
"movl %%eax, 0x10(%%edx)" "\n\t"
"jmp 2f" "\n"
/*
* Come here on an exception. Recover the EXCEPTION_REGISTRATION
*/
"1:" "\t"
"movl %%fs:0, %%edx" "\n\t"
"movl 0x8(%%edx), %%edx" "\n\t"
/*
* Come here however we exited. Restore context from the
* EXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
"2:" "\t"
"movl 0xc(%%edx), %%esp" "\n\t"
"movl 0x8(%%edx), %%ebp" "\n\t"
"movl 0x0(%%edx), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
:
/* No outputs */
:
[registration] "m" (registration),
[nativeDst] "m" (nativeDst),
[nativeSrc] "m" (nativeSrc),
[moveFile] "r" (tclWinProcs->moveFileProc)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
if (registration.status != FALSE) {
retval = TCL_OK;
}
#endif
if (retval != -1)
return retval;
TclWinConvertError(GetLastError());
srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
}
return result;
}
}
}
return TCL_ERROR;
}
| < < < < < < < < < < < < < < < < < | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
}
return result;
}
}
}
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
* TclpObjCopyFile, DoCopyFile --
*
* Copy a single file (not a directory). If dst already exists and
|
| ︙ | ︙ | |||
522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 |
}
static int
DoCopyFile(
CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */
CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */
{
int retval = -1;
/*
* The CopyFile API acts differently under Win95/98 and NT
* WRT NULL and "". Avoid passing these values.
*/
if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
nativeDst == NULL || nativeDst[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
/*
* The CopyFile API would throw an exception under NT if one
* of the arguments is a char block device.
*/
| > > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 |
}
static int
DoCopyFile(
CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */
CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */
{
#ifdef HAVE_NO_SEH
EXCEPTION_REGISTRATION registration;
#endif
int retval = -1;
/*
* The CopyFile API acts differently under Win95/98 and NT
* WRT NULL and "". Avoid passing these values.
*/
if (nativeSrc == NULL || nativeSrc[0] == '\0' ||
nativeDst == NULL || nativeDst[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
/*
* The CopyFile API would throw an exception under NT if one
* of the arguments is a char block device.
*/
#ifndef HAVE_NO_SEH
__try {
if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
retval = TCL_OK;
}
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#else
/*
* Don't have SEH available, do things the hard way.
* Note that this needs to be one block of asm, to avoid stack
* imbalance; also, it is illegal for one asm block to contain
* a jump to another.
*/
__asm__ __volatile__ (
/*
* Pick up parameters before messing with the stack
*/
"movl %[nativeDst], %%ebx" "\n\t"
"movl %[nativeSrc], %%ecx" "\n\t"
/*
* Construct an EXCEPTION_REGISTRATION to protect the
* call to CopyFile
*/
"leal %[registration], %%edx" "\n\t"
"movl %%fs:0, %%eax" "\n\t"
"movl %%eax, 0x0(%%edx)" "\n\t" /* link */
"leal 1f, %%eax" "\n\t"
"movl %%eax, 0x4(%%edx)" "\n\t" /* handler */
"movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */
"movl %%esp, 0xc(%%edx)" "\n\t" /* esp */
"movl $0, 0x10(%%edx)" "\n\t" /* status */
/* Link the EXCEPTION_REGISTRATION on the chain */
"movl %%edx, %%fs:0" "\n\t"
/* Call CopyFile( nativeSrc, nativeDst, 0 ) */
"movl %[copyFile], %%eax" "\n\t"
"pushl $0" "\n\t"
"pushl %%ebx" "\n\t"
"pushl %%ecx" "\n\t"
"call *%%eax" "\n\t"
/*
* Come here on normal exit. Recover the EXCEPTION_REGISTRATION
* and put the status return from CopyFile into it.
*/
"movl %%fs:0, %%edx" "\n\t"
"movl %%eax, 0x10(%%edx)" "\n\t"
"jmp 2f" "\n"
/*
* Come here on an exception. Recover the EXCEPTION_REGISTRATION
*/
"1:" "\t"
"movl %%fs:0, %%edx" "\n\t"
"movl 0x8(%%edx), %%edx" "\n\t"
/*
* Come here however we exited. Restore context from the
* EXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
"2:" "\t"
"movl 0xc(%%edx), %%esp" "\n\t"
"movl 0x8(%%edx), %%ebp" "\n\t"
"movl 0x0(%%edx), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
:
/* No outputs */
:
[registration] "m" (registration),
[nativeDst] "m" (nativeDst),
[nativeSrc] "m" (nativeSrc),
[copyFile] "r" (tclWinProcs->copyFileProc)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
if (registration.status != FALSE) {
retval = TCL_OK;
}
#endif
if (retval != -1)
return retval;
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EBADF) {
Tcl_SetErrno(EACCES);
return TCL_ERROR;
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 |
TclWinConvertError(GetLastError());
(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
}
}
}
return TCL_ERROR;
}
| < < < < < < < < < < < < < < < < | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 |
TclWinConvertError(GetLastError());
(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
}
}
}
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
*
* TclpObjDeleteFile, TclpDeleteFile --
*
* Removes a single file (not a directory).
|
| ︙ | ︙ | |||
850 851 852 853 854 855 856 857 858 |
TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
Tcl_DString srcString, dstString;
int ret;
| > | > > > | | > > > | > > > > > | > | 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 |
TclpObjCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
Tcl_Obj *srcPathPtr;
Tcl_Obj *destPathPtr;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
Tcl_DString srcString, dstString;
Tcl_Obj *normSrcPtr, *normDestPtr;
int ret;
normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
if (normSrcPtr == NULL) {
return TCL_ERROR;
}
Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString);
normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
if (normDestPtr == NULL) {
return TCL_ERROR;
}
Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString);
ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normSrcPtr))) {
*errorPtr = srcPathPtr;
} else if (!strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normDestPtr))) {
*errorPtr = destPathPtr;
} else {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
}
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(*errorPtr);
}
return ret;
}
/*
|
| ︙ | ︙ | |||
906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 |
int
TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
Tcl_Obj *pathPtr;
int recursive;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
int ret;
if (recursive) {
/*
* In the recursive case, the string rep is used to construct a
* Tcl_DString which may be used extensively, so we can't
* optimize this case easily.
*/
Tcl_DString native;
| > | > > > | > > > > | > | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 |
int
TclpObjRemoveDirectory(pathPtr, recursive, errorPtr)
Tcl_Obj *pathPtr;
int recursive;
Tcl_Obj **errorPtr;
{
Tcl_DString ds;
Tcl_Obj *normPtr = NULL;
int ret;
if (recursive) {
/*
* In the recursive case, the string rep is used to construct a
* Tcl_DString which may be used extensively, so we can't
* optimize this case easily.
*/
Tcl_DString native;
normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPtr == NULL) {
return TCL_ERROR;
}
Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr),
0, &ds);
}
if (ret != TCL_OK) {
int len = Tcl_DStringLength(&ds);
if (len > 0) {
if (normPtr != NULL
&& !strcmp(Tcl_DStringValue(&ds), Tcl_GetString(normPtr))) {
*errorPtr = pathPtr;
} else {
*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
}
Tcl_IncrRefCount(*errorPtr);
}
Tcl_DStringFree(&ds);
}
return ret;
}
|
| ︙ | ︙ | |||
1218 1219 1220 1221 1222 1223 1224 |
wp++;
}
if (*wp == '\0') {
continue;
}
}
nativeName = (TCHAR *) data.w.cFileName;
| | | 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 |
wp++;
}
if (*wp == '\0') {
continue;
}
}
nativeName = (TCHAR *) data.w.cFileName;
len = wcslen(data.w.cFileName) * sizeof(WCHAR);
} else {
if ((strcmp(data.a.cFileName, ".") == 0)
|| (strcmp(data.a.cFileName, "..") == 0)) {
continue;
}
nativeName = (TCHAR *) data.a.cFileName;
len = strlen(data.a.cFileName);
|
| ︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 |
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
}
result = TCL_ERROR;
}
| | | 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 |
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
}
result = TCL_ERROR;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TraversalCopy
|
| ︙ | ︙ |
Changes to win/tclWinFile.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclWinFile.c -- * * This file contains temporary wrappers around UNIX file handling * functions. These wrappers map the UNIX functions to Win32 HANDLE-style * files, which can be manipulated through the Win32 console redirection * interfaces. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | /* * tclWinFile.c -- * * This file contains temporary wrappers around UNIX file handling * functions. These wrappers map the UNIX functions to Win32 HANDLE-style * files, which can be manipulated through the Win32 console redirection * interfaces. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinFile.c,v 1.44.2.18 2006/10/17 04:36:45 dgp Exp $ */ //#define _WIN32_WINNT 0x0500 #include "tclWinInt.h" #include <winioctl.h> #include <sys/stat.h> #include <shlobj.h> #include <lmaccess.h> /* For TclpGetUserHome(). */ /* * The number of 100-ns intervals between the Windows system epoch (1601-01-01 * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01). */ #define POSIX_EPOCH_AS_FILETIME 116444736000000000 /* * Declarations for 'link' related information. This information * should come with VC++ 6.0, but is not in some older SDKs. * In any case it is not well documented. */ #ifndef IO_REPARSE_TAG_RESERVED_ONE # define IO_REPARSE_TAG_RESERVED_ONE 0x000000001 |
| ︙ | ︙ | |||
71 72 73 74 75 76 77 78 79 80 81 82 83 84 | # define FILE_SPECIAL_ACCESS (FILE_ANY_ACCESS) #endif #ifndef FSCTL_SET_REPARSE_POINT # define FSCTL_SET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) # define FSCTL_GET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS) # define FSCTL_DELETE_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) #endif /* * Maximum reparse buffer info size. The max user defined reparse * data is 16KB, plus there's a header. */ #define MAX_REPARSE_SIZE 17000 | > > > | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | # define FILE_SPECIAL_ACCESS (FILE_ANY_ACCESS) #endif #ifndef FSCTL_SET_REPARSE_POINT # define FSCTL_SET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) # define FSCTL_GET_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS) # define FSCTL_DELETE_REPARSE_POINT CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) #endif #ifndef INVALID_FILE_ATTRIBUTES #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) #endif /* * Maximum reparse buffer info size. The max user defined reparse * data is 16KB, plus there's a header. */ #define MAX_REPARSE_SIZE 17000 |
| ︙ | ︙ | |||
123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
} REPARSE_DATA_BUFFER;
#endif
typedef struct {
REPARSE_DATA_BUFFER dummy;
WCHAR dummyBuf[MAX_PATH*3];
} DUMMY_REPARSE_BUFFER;
/* Other typedefs required by this code */
static time_t ToCTime(FILETIME fileTime);
typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
(LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
(LPVOID Buffer);
| > > > > > > > > > > > > > > > > > > > > > | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
} REPARSE_DATA_BUFFER;
#endif
typedef struct {
REPARSE_DATA_BUFFER dummy;
WCHAR dummyBuf[MAX_PATH*3];
} DUMMY_REPARSE_BUFFER;
#if defined(_MSC_VER) && ( _MSC_VER <= 1100 )
#define HAVE_NO_FINDEX_ENUMS
#elif !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0400)
#define HAVE_NO_FINDEX_ENUMS
#endif
#ifdef HAVE_NO_FINDEX_ENUMS
/* These two aren't in VC++ 5.2 headers */
typedef enum _FINDEX_INFO_LEVELS {
FindExInfoStandard,
FindExInfoMaxInfoLevel
} FINDEX_INFO_LEVELS;
typedef enum _FINDEX_SEARCH_OPS {
FindExSearchNameMatch,
FindExSearchLimitToDirectories,
FindExSearchLimitToDevices,
FindExSearchMaxSearchOp
} FINDEX_SEARCH_OPS;
#endif /* HAVE_NO_FINDEX_ENUMS */
/* Other typedefs required by this code */
static time_t ToCTime(FILETIME fileTime);
static void FromCTime(time_t posixTime, FILETIME *fileTime);
typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
(LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
(LPVOID Buffer);
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 159 160 161 162 163 164 | static int NativeReadReparse(CONST TCHAR* LinkDirectory, REPARSE_DATA_BUFFER* buffer); static int NativeWriteReparse(CONST TCHAR* LinkDirectory, REPARSE_DATA_BUFFER* buffer); static int NativeMatchType(int isDrive, DWORD attr, CONST TCHAR* nativeName, Tcl_GlobTypeData *types); static int WinIsDrive(CONST char *name, int nameLen); static Tcl_Obj* WinReadLink(CONST TCHAR* LinkSource); static Tcl_Obj* WinReadLinkDirectory(CONST TCHAR* LinkDirectory); static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget, int linkAction); static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory, CONST TCHAR* LinkTarget); | > < | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 | static int NativeReadReparse(CONST TCHAR* LinkDirectory, REPARSE_DATA_BUFFER* buffer); static int NativeWriteReparse(CONST TCHAR* LinkDirectory, REPARSE_DATA_BUFFER* buffer); static int NativeMatchType(int isDrive, DWORD attr, CONST TCHAR* nativeName, Tcl_GlobTypeData *types); static int WinIsDrive(CONST char *name, int nameLen); static int WinIsReserved(CONST char *path); static Tcl_Obj* WinReadLink(CONST TCHAR* LinkSource); static Tcl_Obj* WinReadLinkDirectory(CONST TCHAR* LinkDirectory); static int WinLink(CONST TCHAR* LinkSource, CONST TCHAR* LinkTarget, int linkAction); static int WinSymLinkDirectory(CONST TCHAR* LinkDirectory, CONST TCHAR* LinkTarget); /* *-------------------------------------------------------------------- * * WinLink * * Make a link from source to target. |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | } /* *-------------------------------------------------------------------- * * WinReadLink * | | < | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
}
/*
*--------------------------------------------------------------------
*
* WinReadLink
*
* What does 'LinkSource' point to?
*--------------------------------------------------------------------
*/
static Tcl_Obj*
WinReadLink(LinkSource)
CONST TCHAR* LinkSource;
{
WCHAR tempFileName[MAX_PATH];
|
| ︙ | ︙ | |||
425 426 427 428 429 430 431 | * * This routine reads a NTFS junction, using the undocumented * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points * and junctions. * * Assumption that LinkDirectory is a valid, existing directory. * | | > > > > | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
*
* This routine reads a NTFS junction, using the undocumented
* FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points
* and junctions.
*
* Assumption that LinkDirectory is a valid, existing directory.
*
* Returns a Tcl_Obj with refCount of 1 (i.e. owned by the caller),
* or NULL if anything went wrong.
*
* In the future we should enhance this to return a path object
* rather than a string.
*--------------------------------------------------------------------
*/
static Tcl_Obj*
WinReadLinkDirectory(LinkDirectory)
CONST TCHAR* LinkDirectory;
{
int attr;
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 |
case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK:
case IO_REPARSE_TAG_SYMBOLIC_LINK:
case IO_REPARSE_TAG_MOUNT_POINT: {
Tcl_Obj *retVal;
Tcl_DString ds;
CONST char *copy;
int len;
| | < < < < | < < | | | > > > > > > > > | > > | > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > | > | > | > > > | > > > > > > > > | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 |
case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK:
case IO_REPARSE_TAG_SYMBOLIC_LINK:
case IO_REPARSE_TAG_MOUNT_POINT: {
Tcl_Obj *retVal;
Tcl_DString ds;
CONST char *copy;
int len;
int offset = 0;
/*
* Certain native path representations on Windows have a
* special prefix to indicate that they are to be treated
* specially. For example extremely long paths, or symlinks,
* or volumes mounted inside directories.
*
* There is an assumption in this code that 'wide' interfaces
* are being used (see tclWin32Dll.c), which is true for the
* only systems which support reparse tags at present. If
* that changes in the future, this code will have to be
* generalised.
*/
if (reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer[0]
== L'\\') {
/* Check whether this is a mounted volume */
if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
L"\\??\\Volume{",11) == 0) {
char drive;
/*
* There is some confusion between \??\ and \\?\ which
* we have to fix here. It doesn't seem very well
* documented.
*/
reparseBuffer->SymbolicLinkReparseBuffer
.PathBuffer[1] = L'\\';
/*
* Check if a corresponding drive letter exists, and
* use that if it is found
*/
drive = TclWinDriveLetterForVolMountPoint(reparseBuffer
->SymbolicLinkReparseBuffer.PathBuffer);
if (drive != -1) {
char driveSpec[3] = {
drive, ':', '\0'
};
retVal = Tcl_NewStringObj(driveSpec,2);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* This is actually a mounted drive, which doesn't
* exists as a DOS drive letter. This means the path
* isn't actually a link, although we partially treat
* it like one ('file type' will return 'link'), but
* then the link will actually just be treated like
* an ordinary directory. I don't believe any
* serious inconsistency will arise from this, but it
* is something to be aware of.
*/
Tcl_SetErrno(EINVAL);
return NULL;
} else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
.PathBuffer, L"\\\\?\\",4) == 0) {
/* Strip off the prefix */
offset = 4;
} else if (wcsncmp(reparseBuffer->SymbolicLinkReparseBuffer
.PathBuffer, L"\\??\\",4) == 0) {
/* Strip off the prefix */
offset = 4;
}
}
Tcl_WinTCharToUtf(
(CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
(int)reparseBuffer->SymbolicLinkReparseBuffer
.SubstituteNameLength, &ds);
copy = Tcl_DStringValue(&ds)+offset;
len = Tcl_DStringLength(&ds)-offset;
retVal = Tcl_NewStringObj(copy,len);
Tcl_IncrRefCount(retVal);
Tcl_DStringFree(&ds);
return retVal;
}
}
Tcl_SetErrno(EINVAL);
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 | * * TclpFindExecutable -- * * This procedure computes the absolute path name of the current * application, given its argv[0] value. * * Results: | | | | < | | < > | > > | > | > | | < | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 |
*
* TclpFindExecutable --
*
* This procedure computes the absolute path name of the current
* application, given its argv[0] value.
*
* Results:
* A clean UTF string that is the path to the executable. At this
* point we may not know the system encoding, but we convert the
* string value to UTF-8 using core Windows functions. The path name
* contains ASCII string and '/' chars do not conflict with other UTF
* chars.
*
* Side effects:
* The variable tclNativeExecutableName gets filled in with the file
* name for the application, if we figured it out. If we couldn't
* figure it out, tclNativeExecutableName is set to NULL.
*
*---------------------------------------------------------------------------
*/
char *
TclpFindExecutable(argv0)
CONST char *argv0; /* The value of the application's argv[0]
* (native). */
{
WCHAR wName[MAX_PATH];
char name[MAX_PATH * TCL_UTF_MAX];
if (argv0 == NULL) {
return NULL;
}
if (tclNativeExecutableName != NULL) {
return tclNativeExecutableName;
}
/*
* Under Windows we ignore argv0, and return the path for the file used to
* create this process.
*/
if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) {
GetModuleFileNameA(NULL, name, sizeof(name));
} else {
WideCharToMultiByte(CP_UTF8, 0, wName, -1,
name, sizeof(name), NULL, NULL);
}
tclNativeExecutableName = ckalloc((unsigned) (strlen(name) + 1));
strcpy(tclNativeExecutableName, name);
TclWinNoBackslash(tclNativeExecutableName);
return tclNativeExecutableName;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
741 742 743 744 745 746 747 |
if ((*p != '\\') && (*p != ':')) {
Tcl_DStringAppend(&dirString, "\\", 1);
Tcl_DStringAppend(&dsOrig, "/", 1);
dirLength++;
}
}
dirName = Tcl_DStringValue(&dirString);
| > | | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
if ((*p != '\\') && (*p != ':')) {
Tcl_DStringAppend(&dirString, "\\", 1);
Tcl_DStringAppend(&dsOrig, "/", 1);
dirLength++;
}
}
dirName = Tcl_DStringValue(&dirString);
Tcl_DecrRefCount(fileNamePtr);
/*
* First verify that the specified path is actually a directory.
*/
native = Tcl_WinUtfToTChar(dirName, Tcl_DStringLength(&dirString),
&ds);
attr = (*tclWinProcs->getFileAttributesProc)(native);
|
| ︙ | ︙ | |||
764 765 766 767 768 769 770 | * We need to check all files in the directory, so append a *.* * to the path. */ dirName = Tcl_DStringAppend(&dirString, "*.*", 3); native = Tcl_WinUtfToTChar(dirName, -1, &ds); handle = (*tclWinProcs->findFirstFileProc)(native, &data); | < < > > > | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 |
* We need to check all files in the directory, so append a *.*
* to the path.
*/
dirName = Tcl_DStringAppend(&dirString, "*.*", 3);
native = Tcl_WinUtfToTChar(dirName, -1, &ds);
handle = (*tclWinProcs->findFirstFileProc)(native, &data);
if (handle == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
Tcl_DStringFree(&ds);
Tcl_DStringFree(&dirString);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "couldn't read directory \"",
Tcl_DStringValue(&dsOrig), "\": ",
Tcl_PosixError(interp), (char *) NULL);
Tcl_DStringFree(&dsOrig);
return TCL_ERROR;
}
Tcl_DStringFree(&ds);
/*
* Check to see if the pattern should match the special
* . and .. names, referring to the current directory,
* or the directory above. We need a special check for
* this because paths beginning with a dot are not considered
* hidden on Windows, and so otherwise a relative glob like
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
&& (len == 2 || (name[2] == '/' || name[2] == '\\'))) {
/* Path is of the form 'x:' or 'x:/' or 'x:\' */
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* NativeMatchType --
*
* This function needs a special case for a path which is a root
* volume, because for NTFS root volumes, the getFileAttributesProc
* returns a 'hidden' attribute when it should not.
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | | 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 |
&& (len == 2 || (name[2] == '/' || name[2] == '\\'))) {
/* Path is of the form 'x:' or 'x:/' or 'x:\' */
return 1;
}
}
return 0;
}
/*
* Does the given path represent a reserved window path name? If not
* return 0, if true, return the number of characters of the path that
* we actually want (not any trailing :).
*/
static int WinIsReserved(
CONST char *path) /* Path in UTF-8 */
{
if ((path[0] == 'c' || path[0] == 'C')
&& (path[1] == 'o' || path[1] == 'O')) {
if ((path[2] == 'm' || path[2] == 'M')
&& path[3] >= '1' && path[3] <= '4') {
/* May have match for 'com[1-4]:?', which is a serial port */
if (path[4] == '\0') {
return 4;
} else if (path [4] == ':' && path[5] == '\0') {
return 4;
}
} else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
/* Have match for 'con' */
return 3;
}
} else if ((path[0] == 'l' || path[0] == 'L')
&& (path[1] == 'p' || path[1] == 'P')
&& (path[2] == 't' || path[2] == 'T')) {
if (path[3] >= '1' && path[3] <= '3') {
/* May have match for 'lpt[1-3]:?' */
if (path[4] == '\0') {
return 4;
} else if (path [4] == ':' && path[5] == '\0') {
return 4;
}
}
} else if (stricmp(path, "prn") == 0) {
/* Have match for 'prn' */
return 3;
} else if (stricmp(path, "nul") == 0) {
/* Have match for 'nul' */
return 3;
} else if (stricmp(path, "aux") == 0) {
/* Have match for 'aux' */
return 3;
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* NativeMatchType --
*
* This function needs a special case for a path which is a root
* volume, because for NTFS root volumes, the getFileAttributesProc
* returns a 'hidden' attribute when it should not.
*
* We never make any calss to a 'get attributes' routine here,
* since we have arranged things so that our caller already knows
* such information.
*
* Results:
* 0 = file doesn't match
* 1 = file matches
*
*----------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 |
{
DWORD attr;
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr == 0xffffffff) {
/*
| | > > | > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > | > > > > > > > | | | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 |
{
DWORD attr;
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr == 0xffffffff) {
/*
* File doesn't exist.
*/
TclWinConvertError(GetLastError());
return -1;
}
if ((mode & W_OK)
&& (tclWinProcs->getFileSecurityProc == NULL)
&& (attr & FILE_ATTRIBUTE_READONLY)) {
/*
* We don't have the advanced 'getFileSecurityProc', and
* our attributes say the file is not writable. If we
* do have 'getFileSecurityProc', we'll do a more
* robust XP-related check below.
*/
Tcl_SetErrno(EACCES);
return -1;
}
if (mode & X_OK) {
if (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativePath)) {
/*
* It's not a directory and doesn't have the correct extension.
* Therefore it can't be executable
*/
Tcl_SetErrno(EACCES);
return -1;
}
}
/*
* It looks as if the permissions are ok, but if we are on NT, 2000 or XP,
* we have a more complex permissions structure so we try to check that.
* The code below is remarkably complex for such a simple thing as finding
* what permissions the OS has set for a file.
*
* If we are simply checking for file existence, then we don't need all
* these complications (which are really quite slow: with this code 'file
* readable' is 5-6 times slower than 'file exists').
*/
if ((mode != F_OK) && (tclWinProcs->getFileSecurityProc != NULL)) {
SECURITY_DESCRIPTOR *sdPtr = NULL;
unsigned long size;
GENERIC_MAPPING genMap;
HANDLE hToken = NULL;
DWORD desiredAccess = 0;
DWORD grantedAccess = 0;
BOOL accessYesNo = FALSE;
PRIVILEGE_SET privSet;
DWORD privSetSize = sizeof(PRIVILEGE_SET);
int error;
/*
* First find out how big the buffer needs to be
*/
size = 0;
(*tclWinProcs->getFileSecurityProc)(nativePath,
OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION, 0, 0, &size);
/*
* Should have failed with ERROR_INSUFFICIENT_BUFFER
*/
error = GetLastError();
if (error != ERROR_INSUFFICIENT_BUFFER) {
/*
* Most likely case is ERROR_ACCESS_DENIED, which we will convert
* to EACCES - just what we want!
*/
TclWinConvertError((DWORD)error);
return -1;
}
/*
* Now size contains the size of buffer needed
*/
sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size);
if (sdPtr == NULL) {
goto accessError;
}
/*
* Call GetFileSecurity() for real
*/
if (!(*tclWinProcs->getFileSecurityProc)(nativePath,
OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION, sdPtr, size, &size)) {
/*
* Error getting owner SD
*/
goto accessError;
}
/*
* Perform security impersonation of the user and open the
* resulting thread token.
*/
if (!(*tclWinProcs->impersonateSelfProc)(SecurityImpersonation)) {
/*
* Unable to perform security impersonation.
*/
goto accessError;
}
if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread (),
TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) {
/*
* Unable to get current thread's token.
*/
goto accessError;
}
(*tclWinProcs->revertToSelfProc)();
/*
* Setup desiredAccess according to the access priveleges we are
* checking.
*/
if (mode & R_OK) {
desiredAccess |= FILE_GENERIC_READ;
}
if (mode & W_OK) {
desiredAccess |= FILE_GENERIC_WRITE;
}
if (mode & X_OK) {
desiredAccess |= FILE_GENERIC_EXECUTE;
}
memset (&genMap, 0x0, sizeof (GENERIC_MAPPING));
genMap.GenericRead = FILE_GENERIC_READ;
genMap.GenericWrite = FILE_GENERIC_WRITE;
genMap.GenericExecute = FILE_GENERIC_EXECUTE;
genMap.GenericAll = FILE_ALL_ACCESS;
/*
* Perform access check using the token.
*/
if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess,
&genMap, &privSet, &privSetSize, &grantedAccess,
&accessYesNo)) {
/*
* Unable to perform access check.
*/
accessError:
TclWinConvertError(GetLastError());
if (sdPtr != NULL) {
HeapFree(GetProcessHeap(), 0, sdPtr);
}
if (hToken != NULL) {
CloseHandle(hToken);
}
return -1;
}
/*
* Clean up.
*/
HeapFree(GetProcessHeap (), 0, sdPtr);
CloseHandle(hToken);
if (!accessYesNo) {
Tcl_SetErrno(EACCES);
return -1;
}
/*
* For directories the above checks are ok. For files, though,
* we must still check the 'attr' value.
*/
if ((mode & W_OK)
&& !(attr & FILE_ATTRIBUTE_DIRECTORY)
&& (attr & FILE_ATTRIBUTE_READONLY)) {
Tcl_SetErrno(EACCES);
return -1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* NativeIsExec --
|
| ︙ | ︙ | |||
1254 1255 1256 1257 1258 1259 1260 |
static int
NativeIsExec(nativePath)
CONST TCHAR *nativePath;
{
if (tclWinProcs->useWide) {
CONST WCHAR *path;
int len;
| | | | | > > > | | | | | | 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 |
static int
NativeIsExec(nativePath)
CONST TCHAR *nativePath;
{
if (tclWinProcs->useWide) {
CONST WCHAR *path;
int len;
path = (CONST WCHAR*)nativePath;
len = wcslen(path);
if (len < 5) {
return 0;
}
if (path[len-4] != L'.') {
return 0;
}
/*
* Use wide-char case-insensitive comparison
*/
if ((_wcsicmp(path+len-3,L"exe") == 0)
|| (_wcsicmp(path+len-3,L"com") == 0)
|| (_wcsicmp(path+len-3,L"bat") == 0)) {
return 1;
}
} else {
CONST char *p;
/* We are only looking for pure ascii */
p = strrchr((CONST char*)nativePath, '.');
if (p != NULL) {
p++;
/*
* Note: in the old code, stat considered '.pif' files as
* executable, whereas access did not.
*/
|
| ︙ | ︙ | |||
1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 |
int
TclpObjChdir(pathPtr)
Tcl_Obj *pathPtr; /* Path to new working directory. */
{
int result;
CONST TCHAR *nativePath;
nativePath = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr);
result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
if (result == 0) {
TclWinConvertError(GetLastError());
return -1;
}
return 0;
}
| > > > > > > > > > > > > > > > | 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 |
int
TclpObjChdir(pathPtr)
Tcl_Obj *pathPtr; /* Path to new working directory. */
{
int result;
CONST TCHAR *nativePath;
#ifdef __CYGWIN__
extern int cygwin_conv_to_posix_path
_ANSI_ARGS_((CONST char *, char *));
char posixPath[MAX_PATH+1];
CONST char *path;
Tcl_DString ds;
#endif /* __CYGWIN__ */
nativePath = (CONST TCHAR *) Tcl_FSGetNativePath(pathPtr);
#ifdef __CYGWIN__
/* Cygwin chdir only groks POSIX path. */
path = Tcl_WinTCharToUtf(nativePath, -1, &ds);
cygwin_conv_to_posix_path(path, posixPath);
result = (chdir(posixPath) == 0 ? 1 : 0);
Tcl_DStringFree(&ds);
#else /* __CYGWIN__ */
result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
#endif /* __CYGWIN__ */
if (result == 0) {
TclWinConvertError(GetLastError());
return -1;
}
return 0;
}
|
| ︙ | ︙ | |||
1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 |
/*
* Eliminate file names containing wildcard characters, or subsequent
* call to FindFirstFile() will expand them, matching some other file.
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL || (strpbrk(Tcl_GetString(transPtr), "?*") != NULL)) {
Tcl_SetErrno(ENOENT);
return -1;
}
#endif
/*
* Ensure correct file sizes by forcing the OS to write any
* pending data to disk. This is done only for channels which are
* dirty, i.e. have been written to since the last flush here.
*/
| > > > > | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 |
/*
* Eliminate file names containing wildcard characters, or subsequent
* call to FindFirstFile() will expand them, matching some other file.
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL || (strpbrk(Tcl_GetString(transPtr), "?*") != NULL)) {
if (transPtr != NULL) {
Tcl_DecrRefCount(transPtr);
}
Tcl_SetErrno(ENOENT);
return -1;
}
Tcl_DecrRefCount(transPtr);
#endif
/*
* Ensure correct file sizes by forcing the OS to write any
* pending data to disk. This is done only for channels which are
* dirty, i.e. have been written to since the last flush here.
*/
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 |
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFile() doesn't work on root directories, so call
* GetFileAttributes() to see if the specified file exists.
*/
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
| | | 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 |
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFile() doesn't work on root directories, so call
* GetFileAttributes() to see if the specified file exists.
*/
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr == INVALID_FILE_ATTRIBUTES) {
Tcl_SetErrno(ENOENT);
return -1;
}
/*
* Make up some fake information for this file. It has the
* correct file attributes and a time of 0.
|
| ︙ | ︙ | |||
1711 1712 1713 1714 1715 1716 1717 1718 1719 |
*/
mode |= (mode & 0x0700) >> 3;
mode |= (mode & 0x0700) >> 6;
return (unsigned short)mode;
}
static time_t
ToCTime(
| > > > > > > > > > > > > > | | < < | < > | < | > | | < < > > > | < < < < < | | < | | > | < | | | | | > | | < > | < < < < < < < | < > | | | 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 |
*/
mode |= (mode & 0x0700) >> 3;
mode |= (mode & 0x0700) >> 6;
return (unsigned short)mode;
}
/*
*------------------------------------------------------------------------
*
* ToCTime --
*
* Converts a Windows FILETIME to a time_t in UTC.
*
* Results:
* Returns the count of seconds from the Posix epoch.
*
*------------------------------------------------------------------------
*/
static time_t
ToCTime(
FILETIME fileTime) /* UTC time */
{
LARGE_INTEGER convertedTime;
convertedTime.LowPart = fileTime.dwLowDateTime;
convertedTime.HighPart = (LONG) fileTime.dwHighDateTime;
return (time_t) ((convertedTime.QuadPart
- (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME) / (Tcl_WideInt) 10000000);
}
/*
*------------------------------------------------------------------------
*
* FromCTime --
*
* Converts a time_t to a Windows FILETIME
*
* Results:
* Returns the count of 100-ns ticks seconds from the Windows epoch.
*
*------------------------------------------------------------------------
*/
static void
FromCTime(
time_t posixTime,
FILETIME* fileTime) /* UTC Time */
{
LARGE_INTEGER convertedTime;
convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000
+ POSIX_EPOCH_AS_FILETIME;
fileTime->dwLowDateTime = convertedTime.LowPart;
fileTime->dwHighDateTime = convertedTime.HighPart;
}
#if 0
/*
*-------------------------------------------------------------------------
*
* TclWinResolveShortcut --
*
* Resolve a potential Windows shortcut to get the actual file or
|
| ︙ | ︙ | |||
1936 1937 1938 1939 1940 1941 1942 |
*/
Tcl_Obj*
TclpFilesystemPathType(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
#define VOL_BUF_SIZE 32
int found;
| | | 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 |
*/
Tcl_Obj*
TclpFilesystemPathType(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
#define VOL_BUF_SIZE 32
int found;
WCHAR volType[VOL_BUF_SIZE];
char* firstSeparator;
CONST char *path;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
if (normPath == NULL) return NULL;
path = Tcl_GetString(normPath);
if (path == NULL) return NULL;
|
| ︙ | ︙ | |||
1965 1966 1967 1968 1969 1970 1971 |
if (found == 0) {
return NULL;
} else {
Tcl_DString ds;
Tcl_Obj *objPtr;
| | | 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 |
if (found == 0) {
return NULL;
} else {
Tcl_DString ds;
Tcl_Obj *objPtr;
Tcl_WinTCharToUtf((CONST char *)volType, -1, &ds);
objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
return objPtr;
}
#undef VOL_BUF_SIZE
}
|
| ︙ | ︙ | |||
2038 2039 2040 2041 2042 2043 2044 |
/*
* Now we convert the tail of the current path to its
* 'long form', and append it to 'dsNorm' which holds
* the current normalized path, if the file exists.
*/
if (isDrive) {
| | < > > > > > > > > > > > > > > | | 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 |
/*
* Now we convert the tail of the current path to its
* 'long form', and append it to 'dsNorm' which holds
* the current normalized path, if the file exists.
*/
if (isDrive) {
if (GetFileAttributesA(nativePath) == INVALID_FILE_ATTRIBUTES) {
/* File doesn't exist */
if (isDrive) {
int len = WinIsReserved(path);
if (len > 0) {
/* Actually it does exist - COM1, etc */
int i;
for (i=0;i<len;i++) {
if (nativePath[i] >= 'a') {
((char*)nativePath)[i] -= ('a' - 'A');
}
}
Tcl_DStringAppend(&dsNorm, nativePath, len);
lastValidPathEnd = currentPathEndPosition;
}
}
Tcl_DStringFree(&ds);
break;
}
if (nativePath[0] >= 'a') {
((char*)nativePath)[0] -= ('a' - 'A');
}
Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
} else {
WIN32_FIND_DATA fData;
HANDLE handle;
handle = FindFirstFileA(nativePath, &fData);
if (handle == INVALID_HANDLE_VALUE) {
if (GetFileAttributesA(nativePath)
== INVALID_FILE_ATTRIBUTES) {
/* File doesn't exist */
Tcl_DStringFree(&ds);
break;
}
/* This is usually the '/' in 'c:/' at end of string */
Tcl_DStringAppend(&dsNorm,"/", 1);
} else {
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 |
/* Reached directory separator, or end of string */
WIN32_FILE_ATTRIBUTE_DATA data;
CONST char *nativePath = Tcl_WinUtfToTChar(path,
currentPathEndPosition - path, &ds);
if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
GetFileExInfoStandard, &data) != TRUE) {
/* File doesn't exist */
Tcl_DStringFree(&ds);
break;
}
/*
* File 'nativePath' does exist if we get here. We
* now want to check if it is a symlink and otherwise
| > > > > > > > > > > > > > > > > > | 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 |
/* Reached directory separator, or end of string */
WIN32_FILE_ATTRIBUTE_DATA data;
CONST char *nativePath = Tcl_WinUtfToTChar(path,
currentPathEndPosition - path, &ds);
if ((*tclWinProcs->getFileAttributesExProc)(nativePath,
GetFileExInfoStandard, &data) != TRUE) {
/* File doesn't exist */
if (isDrive) {
int len = WinIsReserved(path);
if (len > 0) {
/* Actually it does exist - COM1, etc */
int i;
for (i=0;i<len;i++) {
WCHAR wc = ((WCHAR*)nativePath)[i];
if (wc >= L'a') {
wc -= (L'a' - L'A');
((WCHAR*)nativePath)[i] = wc;
}
}
Tcl_DStringAppend(&dsNorm, nativePath,
sizeof(WCHAR)*len);
lastValidPathEnd = currentPathEndPosition;
}
}
Tcl_DStringFree(&ds);
break;
}
/*
* File 'nativePath' does exist if we get here. We
* now want to check if it is a symlink and otherwise
|
| ︙ | ︙ | |||
2164 2165 2166 2167 2168 2169 2170 |
WCHAR drive = ((WCHAR*)nativePath)[0];
if (drive >= L'a') {
drive -= (L'a' - L'A');
((WCHAR*)nativePath)[0] = drive;
}
Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
} else {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | > | 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 |
WCHAR drive = ((WCHAR*)nativePath)[0];
if (drive >= L'a') {
drive -= (L'a' - L'A');
((WCHAR*)nativePath)[0] = drive;
}
Tcl_DStringAppend(&dsNorm,nativePath,Tcl_DStringLength(&ds));
} else {
char *checkDots = NULL;
if (lastValidPathEnd[1] == '.') {
checkDots = lastValidPathEnd + 1;
while (checkDots < currentPathEndPosition) {
if (*checkDots != '.') {
checkDots = NULL;
break;
}
checkDots++;
}
}
if (checkDots != NULL) {
int dotLen = currentPathEndPosition - lastValidPathEnd;
/*
* Path is just dots. We shouldn't really
* ever see a path like that. However, to be
* nice we at least don't mangle the path --
* we just add the dots as a path segment and
* continue
*/
Tcl_DStringAppend(&dsNorm,
(TCHAR*)((WCHAR*)(nativePath
+ Tcl_DStringLength(&ds))
- dotLen),
(int)(dotLen * sizeof(WCHAR)));
} else {
/* Normal path */
WIN32_FIND_DATAW fData;
HANDLE handle;
handle = FindFirstFileW((WCHAR*)nativePath, &fData);
if (handle == INVALID_HANDLE_VALUE) {
/* This is usually the '/' in 'c:/' at end of string */
Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
sizeof(WCHAR));
} else {
WCHAR *nativeName;
if (fData.cFileName[0] != '\0') {
nativeName = fData.cFileName;
} else {
nativeName = fData.cAlternateFileName;
}
FindClose(handle);
Tcl_DStringAppend(&dsNorm,(CONST char*)L"/",
sizeof(WCHAR));
Tcl_DStringAppend(&dsNorm,(TCHAR*)nativeName,
(int) (wcslen(nativeName)*sizeof(WCHAR)));
}
}
}
Tcl_DStringFree(&ds);
lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
break;
}
|
| ︙ | ︙ | |||
2246 2247 2248 2249 2250 2251 2252 | * * Set the modification date for a file. * * Results: * 0 on success, -1 on error. * * Side effects: | > | > | | | | > > > > > > > > > > > > > > > > > | < < > > | > > > | > > > | < | < > > > | 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 |
*
* Set the modification date for a file.
*
* Results:
* 0 on success, -1 on error.
*
* Side effects:
* Sets errno to a representation of any Windows problem that's observed
* in the process.
*
*---------------------------------------------------------------------------
*/
int
TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
int res = 0;
HANDLE fileHandle;
CONST TCHAR *native;
DWORD attr = 0;
DWORD flags = FILE_ATTRIBUTE_NORMAL;
FILETIME lastAccessTime, lastModTime;
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
native = (CONST TCHAR *)Tcl_FSGetNativePath(pathPtr);
attr = (*tclWinProcs->getFileAttributesProc)(native);
if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) {
flags = FILE_FLAG_BACKUP_SEMANTICS;
}
/*
* We use the native APIs (not 'utime') because there are some daylight
* savings complications that utime gets wrong.
*/
fileHandle = (tclWinProcs->createFileProc) (
native, FILE_WRITE_ATTRIBUTES, 0, NULL,
OPEN_EXISTING, flags, NULL);
if (fileHandle == INVALID_HANDLE_VALUE ||
!SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
TclWinConvertError(GetLastError());
res = -1;
}
if (fileHandle != INVALID_HANDLE_VALUE) {
CloseHandle(fileHandle);
}
return res;
}
|
Changes to win/tclWinInit.c.
1 2 3 4 5 6 7 8 9 | /* * tclWinInit.c -- * * Contains the Windows-specific interpreter initialization functions. * * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclWinInit.c -- * * Contains the Windows-specific interpreter initialization functions. * * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * All rights reserved. * * RCS: @(#) $Id: tclWinInit.c,v 1.40.2.6 2005/10/23 22:01:31 msofer Exp $ */ #include "tclWinInt.h" #include <winnt.h> #include <winbase.h> #include <lmcons.h> |
| ︙ | ︙ | |||
54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | #endif #ifndef PROCESSOR_ARCHITECTURE_ALPHA64 #define PROCESSOR_ARCHITECTURE_ALPHA64 7 #endif #ifndef PROCESSOR_ARCHITECTURE_MSIL #define PROCESSOR_ARCHITECTURE_MSIL 8 #endif #ifndef PROCESSOR_ARCHITECTURE_UNKNOWN #define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF #endif /* * The following arrays contain the human readable strings for the Windows * platform and processor values. */ | > > > > > > | | | | > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
#endif
#ifndef PROCESSOR_ARCHITECTURE_ALPHA64
#define PROCESSOR_ARCHITECTURE_ALPHA64 7
#endif
#ifndef PROCESSOR_ARCHITECTURE_MSIL
#define PROCESSOR_ARCHITECTURE_MSIL 8
#endif
#ifndef PROCESSOR_ARCHITECTURE_AMD64
#define PROCESSOR_ARCHITECTURE_AMD64 9
#endif
#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10
#endif
#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN
#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
#endif
/*
* The following arrays contain the human readable strings for the Windows
* platform and processor values.
*/
#define NUMPLATFORMS 4
static char* platforms[NUMPLATFORMS] = {
"Win32s", "Windows 95", "Windows NT", "Windows CE"
};
#define NUMPROCESSORS 11
static char* processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
/* Used to store the encoding used for binary files */
static Tcl_Encoding binaryEncoding = NULL;
/* Has the basic library path encoding issue been fixed */
static int libraryPathEncodingFixed = 0;
|
| ︙ | ︙ | |||
154 155 156 157 158 159 160 | * This call sets the library path to strings in UTF-8. Any * pre-existing library path information is assumed to have been * in the native multibyte encoding. * * Called at process initialization time. * * Results: | | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 |
* This call sets the library path to strings in UTF-8. Any
* pre-existing library path information is assumed to have been
* in the native multibyte encoding.
*
* Called at process initialization time.
*
* Results:
* Return 0, indicating that the UTF is clean.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
TclpInitLibraryPath(path)
CONST char *path; /* Potentially dirty UTF string that is */
/* the path to the executable name. */
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
CONST char *str;
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
* Initialize the substrings used when locating an executable. The
* installLib variable computes the path as though the executable
* is installed. The developLib computes the path as though the
* executable is run from a develpment directory.
*/
sprintf(installLib, "lib/tcl%s", TCL_VERSION);
| | | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
* Initialize the substrings used when locating an executable. The
* installLib variable computes the path as though the executable
* is installed. The developLib computes the path as though the
* executable is run from a develpment directory.
*/
sprintf(installLib, "lib/tcl%s", TCL_VERSION);
sprintf(developLib, "tcl%s/library", TCL_PATCH_LEVEL);
/*
* Look for the library relative to default encoding dir.
*/
str = Tcl_GetDefaultEncodingDir();
if ((str != NULL) && (str[0] != '\0')) {
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
/*
* The variable path holds an absolute path. Take care not to
* overwrite pathv[0] since that might produce a relative path.
*/
if (path != NULL) {
| > > > | > > > > > > > > > > > > > > > | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 |
/*
* The variable path holds an absolute path. Take care not to
* overwrite pathv[0] since that might produce a relative path.
*/
if (path != NULL) {
int i, origc;
CONST char **origv;
Tcl_SplitPath(path, &origc, &origv);
pathc = 0;
pathv = (CONST char **) ckalloc((unsigned int)(origc * sizeof(char *)));
for (i=0; i< origc; i++) {
if (origv[i][0] == '.') {
if (strcmp(origv[i], ".") == 0) {
/* do nothing */
} else if (strcmp(origv[i], "..") == 0) {
pathc--;
} else {
pathv[pathc++] = origv[i];
}
} else {
pathv[pathc++] = origv[i];
}
}
if (pathc > 2) {
str = pathv[pathc - 2];
pathv[pathc - 2] = installLib;
path = Tcl_JoinPath(pathc - 1, pathv, &ds);
pathv[pathc - 2] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
pathv[pathc - 4] = developLib;
path = Tcl_JoinPath(pathc - 3, pathv, &ds);
pathv[pathc - 4] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
ckfree((char *) pathv);
}
TclSetLibraryPath(pathPtr);
}
/*
*---------------------------------------------------------------------------
*
* AppendEnvironment --
*
| > > > | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
pathv[pathc - 4] = developLib;
path = Tcl_JoinPath(pathc - 3, pathv, &ds);
pathv[pathc - 4] = str;
objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
Tcl_DStringFree(&ds);
}
ckfree((char *) origv);
ckfree((char *) pathv);
}
TclSetLibraryPath(pathPtr);
return 0; /* 0 indicates that pathPtr is clean (true) utf */
}
/*
*---------------------------------------------------------------------------
*
* AppendEnvironment --
*
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 339 340 341 342 343 344 345 |
{
int pathc;
WCHAR wBuf[MAX_PATH];
char buf[MAX_PATH * TCL_UTF_MAX];
Tcl_Obj *objPtr;
Tcl_DString ds;
CONST char **pathv;
/*
* The "L" preceeding the TCL_LIBRARY string is used to tell VC++
* that this is a unicode string.
*/
if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
| > > > > > > > > > > > > > > > > > > > | 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 |
{
int pathc;
WCHAR wBuf[MAX_PATH];
char buf[MAX_PATH * TCL_UTF_MAX];
Tcl_Obj *objPtr;
Tcl_DString ds;
CONST char **pathv;
char *shortlib;
/*
* The shortlib value needs to be the tail component of the
* lib path. For example, "lib/tcl8.4" -> "tcl8.4" while
* "usr/share/tcl8.5" -> "tcl8.5".
*/
for (shortlib = (char *) (lib + strlen(lib) - 1); shortlib > lib ; shortlib--) {
if (*shortlib == '/') {
if (shortlib == (lib + strlen(lib) - 1)) {
Tcl_Panic("last character in lib cannot be '/'");
}
shortlib++;
break;
}
}
if (shortlib == lib) {
Tcl_Panic("no '/' character found in lib");
}
/*
* The "L" preceeding the TCL_LIBRARY string is used to tell VC++
* that this is a unicode string.
*/
if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
|
| ︙ | ︙ | |||
354 355 356 357 358 359 360 | Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); TclWinNoBackslash(buf); Tcl_SplitPath(buf, &pathc, &pathv); /* * The lstrcmpi() will work even if pathv[pathc - 1] is random | | | | | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 |
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
TclWinNoBackslash(buf);
Tcl_SplitPath(buf, &pathc, &pathv);
/*
* The lstrcmpi() will work even if pathv[pathc - 1] is random
* UTF-8 chars because I know shortlib is ascii.
*/
if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) {
CONST char *str;
/*
* TCL_LIBRARY is set but refers to a different tcl
* installation than the current version. Try fiddling with the
* specified directory to make it refer to this installation by
* removing the old "tclX.Y" and substituting the current
* version string.
*/
pathv[pathc - 1] = shortlib;
Tcl_DStringInit(&ds);
str = Tcl_JoinPath(pathc, pathv, &ds);
objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
} else {
objPtr = Tcl_NewStringObj(buf, -1);
}
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
void
TclpSetInitialEncodings()
{
CONST char *encoding;
char buf[4 + TCL_INTEGER_SPACE];
if (libraryPathEncodingFixed == 0) {
| | > > > | | | | 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 |
void
TclpSetInitialEncodings()
{
CONST char *encoding;
char buf[4 + TCL_INTEGER_SPACE];
if (libraryPathEncodingFixed == 0) {
int platformId, useWide;
platformId = TclWinGetPlatformId();
useWide = ((platformId == VER_PLATFORM_WIN32_NT)
|| (platformId == VER_PLATFORM_WIN32_CE));
TclWinSetInterfaces(useWide);
wsprintfA(buf, "cp%d", GetACP());
Tcl_SetSystemEncoding(NULL, buf);
if (!useWide) {
Tcl_Obj *pathPtr = TclGetLibraryPath();
if (pathPtr != NULL) {
int i, objc;
Tcl_Obj **objv;
objc = 0;
Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
|
| ︙ | ︙ | |||
793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 |
};
}
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
pathPtr = Tcl_NewObj();
}
Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
return Tcl_Eval(interp, initScript);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceRCFile --
| > > | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
};
}
pathPtr = TclGetLibraryPath();
if (pathPtr == NULL) {
pathPtr = Tcl_NewObj();
}
Tcl_IncrRefCount(pathPtr);
Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(pathPtr);
return Tcl_Eval(interp, initScript);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SourceRCFile --
|
| ︙ | ︙ |
Changes to win/tclWinInt.h.
1 2 3 4 5 6 7 8 9 10 | /* * tclWinInt.h -- * * Declarations of Windows-specific shared variables and procedures. * * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | /* * tclWinInt.h -- * * Declarations of Windows-specific shared variables and procedures. * * Copyright (c) 1994-1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinInt.h,v 1.20.2.5 2006/03/10 10:35:25 vincentdarley Exp $ */ #ifndef _TCLWININT #define _TCLWININT #ifndef _TCLINT #include "tclInt.h" #endif #ifndef _TCLPORT #include "tclPort.h" #endif /* * The following specifies how much stack space TclpCheckStackSpace() * ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj() * to help avoid overflowing the stack in the case of infinite recursion. */ #define TCL_WIN_STACK_THRESHOLD 0x8000 #ifdef BUILD_tcl # undef TCL_STORAGE_CLASS # define TCL_STORAGE_CLASS DLLEXPORT #endif /* * Some versions of Borland C have a define for the OSVERSIONINFO for * Win32s and for NT, but not for Windows 95. * Define VER_PLATFORM_WIN32_CE for those without newer headers. */ #ifndef VER_PLATFORM_WIN32_WINDOWS #define VER_PLATFORM_WIN32_WINDOWS 1 #endif #ifndef VER_PLATFORM_WIN32_CE #define VER_PLATFORM_WIN32_CE 3 #endif /* * The following structure keeps track of whether we are using the * multi-byte or the wide-character interfaces to the operating system. * System calls should be made through the following function table. */ |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
*/
BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *,
GET_FILEEX_INFO_LEVELS, LPVOID);
BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*,
LPSECURITY_ATTRIBUTES);
INT (__cdecl *utimeProc)(CONST TCHAR*, struct _utimbuf *);
| > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
*/
BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *,
GET_FILEEX_INFO_LEVELS, LPVOID);
BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*,
LPSECURITY_ATTRIBUTES);
INT (__cdecl *utimeProc)(CONST TCHAR*, struct _utimbuf *);
/* These two are also NULL at start; see comment above */
HANDLE (WINAPI *findFirstFileExProc)(CONST TCHAR*, UINT,
LPVOID, UINT,
LPVOID, DWORD);
BOOL (WINAPI *getVolumeNameForVMPProc)(CONST TCHAR*, TCHAR*, DWORD);
DWORD (WINAPI *getLongPathNameProc)(CONST TCHAR*, TCHAR*, DWORD);
/*
* These six are for the security sdk to get correct file
* permissions on NT, 2000, XP, etc. On 95,98,ME they are
* always null.
*/
BOOL (WINAPI *getFileSecurityProc)(LPCTSTR lpFileName,
SECURITY_INFORMATION RequestedInformation,
PSECURITY_DESCRIPTOR pSecurityDescriptor,
DWORD nLength,
LPDWORD lpnLengthNeeded);
BOOL (WINAPI *impersonateSelfProc) (SECURITY_IMPERSONATION_LEVEL
ImpersonationLevel);
BOOL (WINAPI *openThreadTokenProc) (HANDLE ThreadHandle,
DWORD DesiredAccess, BOOL OpenAsSelf,
PHANDLE TokenHandle);
BOOL (WINAPI *revertToSelfProc) (void);
VOID (WINAPI *mapGenericMaskProc) (PDWORD AccessMask,
PGENERIC_MAPPING GenericMapping);
BOOL (WINAPI *accessCheckProc)(PSECURITY_DESCRIPTOR pSecurityDescriptor,
HANDLE ClientToken, DWORD DesiredAccess,
PGENERIC_MAPPING GenericMapping,
PPRIVILEGE_SET PrivilegeSet,
LPDWORD PrivilegeSetLength,
LPDWORD GrantedAccess,
LPBOOL AccessStatus);
/*
* Unicode console support. WriteConsole and ReadConsole
*/
BOOL (WINAPI *readConsoleProc)(HANDLE hConsoleInput,
LPVOID lpBuffer,
DWORD nNumberOfCharsToRead,
LPDWORD lpNumberOfCharsRead,
LPVOID lpReserved);
BOOL (WINAPI *writeConsoleProc)(HANDLE hConsoleOutput,
const VOID* lpBuffer,
DWORD nNumberOfCharsToWrite,
LPDWORD lpNumberOfCharsWritten,
LPVOID lpReserved);
} TclWinProcs;
EXTERN TclWinProcs *tclWinProcs;
/*
* Declarations of functions that are not accessible by way of the
* stubs table.
*/
EXTERN void TclWinEncodingsCleanup();
EXTERN void TclWinResetInterfaceEncodings();
EXTERN void TclWinInit(HINSTANCE hInst);
EXTERN int TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal,
CONST TCHAR* LinkCopy);
EXTERN int TclWinSymLinkDelete(CONST TCHAR* LinkOriginal,
int linkOnly);
EXTERN char TclWinDriveLetterForVolMountPoint(CONST WCHAR *mountPoint);
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
EXTERN void TclWinFreeAllocCache(void);
EXTERN void TclFreeAllocCache(void *);
EXTERN Tcl_Mutex *TclpNewAllocMutex(void);
EXTERN void *TclpGetAllocCache(void);
EXTERN void TclpSetAllocCache(void *);
#endif /* TCL_THREADS */
|
| ︙ | ︙ |
Changes to win/tclWinNotify.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclWinNotify.c -- * * This file contains Windows-specific procedures for the notifier, * which is the lowest-level part of the Tcl event loop. This file * works together with ../generic/tclNotify.c. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclWinNotify.c -- * * This file contains Windows-specific procedures for the notifier, * which is the lowest-level part of the Tcl event loop. This file * works together with ../generic/tclNotify.c. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinNotify.c,v 1.11.2.1 2003/03/21 03:24:09 dgp Exp $ */ #include "tclWinInt.h" /* * The follwing static indicates whether this module has been initialized. */ |
| ︙ | ︙ | |||
41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
int timeout; /* Current timeout value. */
int timerActive; /* 1 if interval timer is running. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
extern TclStubs tclStubs;
/*
* The following static indicates the number of threads that have
* initialized notifiers. It controls the lifetime of the TclNotifier
* window class.
*
* You must hold the notifierMutex lock before accessing this variable.
*/
| > > | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
int timeout; /* Current timeout value. */
int timerActive; /* 1 if interval timer is running. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
extern TclStubs tclStubs;
extern Tcl_NotifierProcs tclOriginalNotifier;
/*
* The following static indicates the number of threads that have
* initialized notifiers. It controls the lifetime of the TclNotifier
* window class.
*
* You must hold the notifierMutex lock before accessing this variable.
*/
|
| ︙ | ︙ | |||
263 264 265 266 267 268 269 |
UINT timeout;
/*
* Allow the notifier to be hooked. This may not make sense
* on Windows, but mirrors the UNIX hook.
*/
| | | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
UINT timeout;
/*
* Allow the notifier to be hooked. This may not make sense
* on Windows, but mirrors the UNIX hook.
*/
if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) {
tclStubs.tcl_SetTimer(timePtr);
return;
}
/*
* We only need to set up an interval timer if we're being called
* from an external event loop. If we don't have a window handle
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
int status;
/*
* Allow the notifier to be hooked. This may not make
* sense on windows, but mirrors the UNIX hook.
*/
| | | 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 |
int status;
/*
* Allow the notifier to be hooked. This may not make
* sense on windows, but mirrors the UNIX hook.
*/
if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) {
return tclStubs.tcl_WaitForEvent(timePtr);
}
/*
* Compute the timeout in milliseconds.
*/
|
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclWinPipe.c -- * * This file implements the Windows-specific exec pipeline functions, * the "pipe" channel driver, and the "pid" Tcl command. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclWinPipe.c -- * * This file implements the Windows-specific exec pipeline functions, * the "pipe" channel driver, and the "pid" Tcl command. * * Copyright (c) 1996-1997 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinPipe.c,v 1.33.2.17 2006/03/14 20:36:39 andreas_kupries Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> |
| ︙ | ︙ | |||
185 186 187 188 189 190 191 | CONST char **argv, Tcl_DString *linePtr); static BOOL HasConsole(void); static int PipeBlockModeProc(ClientData instanceData, int mode); static void PipeCheckProc(ClientData clientData, int flags); static int PipeClose2Proc(ClientData instanceData, Tcl_Interp *interp, int flags); static int PipeEventProc(Tcl_Event *evPtr, int flags); | < < > > > | > > | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 |
CONST char **argv, Tcl_DString *linePtr);
static BOOL HasConsole(void);
static int PipeBlockModeProc(ClientData instanceData, int mode);
static void PipeCheckProc(ClientData clientData, int flags);
static int PipeClose2Proc(ClientData instanceData,
Tcl_Interp *interp, int flags);
static int PipeEventProc(Tcl_Event *evPtr, int flags);
static int PipeGetHandleProc(ClientData instanceData,
int direction, ClientData *handlePtr);
static void PipeInit(void);
static int PipeInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
static int PipeOutputProc(ClientData instanceData,
CONST char *buf, int toWrite, int *errorCode);
static DWORD WINAPI PipeReaderThread(LPVOID arg);
static void PipeSetupProc(ClientData clientData, int flags);
static void PipeWatchProc(ClientData instanceData, int mask);
static DWORD WINAPI PipeWriterThread(LPVOID arg);
static int TempFileName(WCHAR name[MAX_PATH]);
static int WaitForRead(PipeInfo *infoPtr, int blocking);
static void PipeThreadActionProc _ANSI_ARGS_ ((
ClientData instanceData, int action));
/*
* This structure describes the channel type structure for command pipe
* based IO.
*/
static Tcl_ChannelType pipeChannelType = {
"pipe", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
TCL_CLOSE2PROC, /* Close proc. */
PipeInputProc, /* Input proc. */
PipeOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
NULL, /* Get option proc. */
PipeWatchProc, /* Set up notifier to watch the channel. */
PipeGetHandleProc, /* Get an OS handle from channel. */
PipeClose2Proc, /* close2proc */
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
PipeThreadActionProc, /* thread action proc */
};
/*
*----------------------------------------------------------------------
*
* PipeInit --
*
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
*/
if (!initialized) {
Tcl_MutexLock(&pipeMutex);
if (!initialized) {
initialized = 1;
procList = NULL;
| < < | | | | | < | < < | < < | < < < < < > | < < < < < < < > | < < < < < < < | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 |
*/
if (!initialized) {
Tcl_MutexLock(&pipeMutex);
if (!initialized) {
initialized = 1;
procList = NULL;
}
Tcl_MutexUnlock(&pipeMutex);
}
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->firstPipePtr = NULL;
Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizePipes --
*
* This function is called from Tcl_FinalizeThread to finalize the
* platform specific pipe subsystem.
*
* Results:
* None.
*
* Side effects:
* Removes the pipe event source.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizePipes()
{
ThreadSpecificData *tsdPtr;
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL);
}
}
/*
*----------------------------------------------------------------------
*
* PipeSetupProc --
*
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
return NULL;
}
/*
* Seek to the end of file if we are writing.
*/
| | | 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
return NULL;
}
/*
* Seek to the end of file if we are writing.
*/
if (mode & (O_WRONLY|O_APPEND)) {
SetFilePointer(handle, 0, NULL, FILE_END);
}
return TclWinMakeFile(handle);
}
/*
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 908 909 910 911 912 913 914 |
*/
unsigned long
TclpGetPid(
Tcl_Pid pid) /* The HANDLE of the child process. */
{
ProcInfo *infoPtr;
Tcl_MutexLock(&pipeMutex);
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->hProcess == (HANDLE) pid) {
Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
| > > | 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 |
*/
unsigned long
TclpGetPid(
Tcl_Pid pid) /* The HANDLE of the child process. */
{
ProcInfo *infoPtr;
PipeInit();
Tcl_MutexLock(&pipeMutex);
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->hProcess == (HANDLE) pid) {
Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 | * of a hidden console application, and then run that hidden * console as a detached process. */ startInfo.wShowWindow = SW_HIDE; startInfo.dwFlags |= STARTF_USESHOWWINDOW; createFlags = CREATE_NEW_CONSOLE; | | | 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 |
* of a hidden console application, and then run that hidden
* console as a detached process.
*/
startInfo.wShowWindow = SW_HIDE;
startInfo.dwFlags |= STARTF_USESHOWWINDOW;
createFlags = CREATE_NEW_CONSOLE;
Tcl_DStringAppend(&cmdLine, "cmd.exe /c", -1);
} else {
createFlags = DETACHED_PROCESS;
}
} else {
if (HasConsole()) {
createFlags = 0;
} else {
|
| ︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 |
{
Tcl_Obj *tclExePtr, *pipeDllPtr;
int i, fileExists;
char *start,*end;
Tcl_DString pipeDll;
Tcl_DStringInit(&pipeDll);
| | < < | 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 |
{
Tcl_Obj *tclExePtr, *pipeDllPtr;
int i, fileExists;
char *start,*end;
Tcl_DString pipeDll;
Tcl_DStringInit(&pipeDll);
Tcl_DStringAppend(&pipeDll, TCL_PIPE_DLL, -1);
tclExePtr = Tcl_NewStringObj(TclpFindExecutable(""), -1);
start = Tcl_GetStringFromObj(tclExePtr, &i);
for (end = start + (i-1); end > start; end--) {
if (*end == '/')
break;
}
if (*end != '/')
|
| ︙ | ︙ | |||
1565 1566 1567 1568 1569 1570 1571 |
CONST char *arg, *start, *special;
int quote, i;
Tcl_DString ds;
Tcl_DStringInit(&ds);
/*
| | > | > | > > | > | < | | | | > | | < < < < < | | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 |
CONST char *arg, *start, *special;
int quote, i;
Tcl_DString ds;
Tcl_DStringInit(&ds);
/*
* Prime the path. Add a space separator if we were primed with
* something.
*/
Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1);
if (Tcl_DStringLength(&ds) > 0) Tcl_DStringAppend(&ds, " ", 1);
for (i = 0; i < argc; i++) {
if (i == 0) {
arg = executable;
} else {
arg = argv[i];
Tcl_DStringAppend(&ds, " ", 1);
}
quote = 0;
if (arg[0] == '\0') {
quote = 1;
} else {
int count;
Tcl_UniChar ch;
for (start = arg; *start != '\0'; start += count) {
count = Tcl_UtfToUniChar(start, &ch);
if (Tcl_UniCharIsSpace(ch)) { /* INTL: ISO space. */
quote = 1;
break;
}
}
}
if (quote) {
Tcl_DStringAppend(&ds, "\"", 1);
}
start = arg;
for (special = arg; ; ) {
if ((*special == '\\') &&
(special[1] == '\\' || special[1] == '"' || (quote && special[1] == '\0'))) {
Tcl_DStringAppend(&ds, start, (int) (special - start));
start = special;
while (1) {
special++;
if (*special == '"' || (quote && *special == '\0')) {
/*
* N backslashes followed a quote -> insert
* N * 2 + 1 backslashes then a quote.
*/
Tcl_DStringAppend(&ds, start,
(int) (special - start));
break;
}
if (*special != '\\') {
break;
}
}
Tcl_DStringAppend(&ds, start, (int) (special - start));
start = special;
}
if (*special == '"') {
Tcl_DStringAppend(&ds, start, (int) (special - start));
Tcl_DStringAppend(&ds, "\\\"", 2);
start = special + 1;
}
if (*special == '\0') {
break;
}
special++;
}
Tcl_DStringAppend(&ds, start, (int) (special - start));
if (quote) {
Tcl_DStringAppend(&ds, "\"", 1);
}
}
Tcl_DStringFree(linePtr);
Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 |
infoPtr->writeFile = writeFile;
infoPtr->errorFile = errorFile;
infoPtr->numPids = numPids;
infoPtr->pidPtr = pidPtr;
infoPtr->writeBuf = 0;
infoPtr->writeBufLen = 0;
infoPtr->writeError = 0;
/*
* Use one of the fds associated with the channel as the
* channel id.
*/
if (readFile) {
| > | 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 |
infoPtr->writeFile = writeFile;
infoPtr->errorFile = errorFile;
infoPtr->numPids = numPids;
infoPtr->pidPtr = pidPtr;
infoPtr->writeBuf = 0;
infoPtr->writeBufLen = 0;
infoPtr->writeError = 0;
infoPtr->channel = (Tcl_Channel) NULL;
/*
* Use one of the fds associated with the channel as the
* channel id.
*/
if (readFile) {
|
| ︙ | ︙ | |||
1879 1880 1881 1882 1883 1884 1885 |
int errorCode, result;
PipeInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
DWORD exitCode;
errorCode = 0;
if ((!flags || (flags == TCL_CLOSE_READ))
| | | 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 |
int errorCode, result;
PipeInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
DWORD exitCode;
errorCode = 0;
if ((!flags || (flags == TCL_CLOSE_READ))
&& (pipePtr->readFile != NULL)) {
/*
* Clean up the background thread if necessary. Note that this
* must be done before we can close the file, since the
* thread may be blocking trying to read from the pipe.
*/
if (pipePtr->readThread) {
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 | SetEvent(pipePtr->stopReader); /* * Wait at most 20 milliseconds for the reader thread to close. */ if (WaitForSingleObject(pipePtr->readThread, 20) | | | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 |
SetEvent(pipePtr->stopReader);
/*
* Wait at most 20 milliseconds for the reader thread to close.
*/
if (WaitForSingleObject(pipePtr->readThread, 20)
== WAIT_TIMEOUT) {
/*
* The thread must be blocked waiting for the pipe to
* become readable in ReadFile(). There isn't a clean way
* to exit the thread from this condition. We should
* terminate the child process instead to get the reader
* thread to fall out of ReadFile with a FALSE. (below) is
* not the correct way to do this, but will stay here until
|
| ︙ | ︙ | |||
1944 1945 1946 1947 1948 1949 1950 |
if (TclpCloseFile(pipePtr->readFile) != 0) {
errorCode = errno;
}
pipePtr->validMask &= ~TCL_READABLE;
pipePtr->readFile = NULL;
}
if ((!flags || (flags & TCL_CLOSE_WRITE))
| | | 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 |
if (TclpCloseFile(pipePtr->readFile) != 0) {
errorCode = errno;
}
pipePtr->validMask &= ~TCL_READABLE;
pipePtr->readFile = NULL;
}
if ((!flags || (flags & TCL_CLOSE_WRITE))
&& (pipePtr->writeFile != NULL)) {
if (pipePtr->writeThread) {
/*
* Wait for the writer thread to finish the current buffer,
* then terminate the thread and close the handles. If the
* channel is nonblocking, there should be no pending write
* operations.
|
| ︙ | ︙ | |||
1977 1978 1979 1980 1981 1982 1983 | SetEvent(pipePtr->stopWriter); /* * Wait at most 20 milliseconds for the reader thread to close. */ if (WaitForSingleObject(pipePtr->writeThread, 20) | | | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
SetEvent(pipePtr->stopWriter);
/*
* Wait at most 20 milliseconds for the reader thread to close.
*/
if (WaitForSingleObject(pipePtr->writeThread, 20)
== WAIT_TIMEOUT) {
/*
* The thread must be blocked waiting for the pipe to
* consume input in WriteFile(). There isn't a clean way
* to exit the thread from this condition. We should
* terminate the child process instead to get the writer
* thread to fall out of WriteFile with a FALSE. (below) is
* not the correct way to do this, but will stay here until
|
| ︙ | ︙ | |||
2030 2031 2032 2033 2034 2035 2036 |
}
/*
* Remove the file from the list of watched files.
*/
for (nextPtrPtr = &(tsdPtr->firstPipePtr), infoPtr = *nextPtrPtr;
| | | > | > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | > | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 |
}
/*
* Remove the file from the list of watched files.
*/
for (nextPtrPtr = &(tsdPtr->firstPipePtr), infoPtr = *nextPtrPtr;
infoPtr != NULL;
nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
if (infoPtr == (PipeInfo *)pipePtr) {
*nextPtrPtr = infoPtr->nextPtr;
break;
}
}
if ((pipePtr->flags & PIPE_ASYNC) || TclInExit()) {
/*
* If the channel is non-blocking or Tcl is being cleaned up,
* just detach the children PIDs, reap them (important if we are
* in a dynamic load module), and discard the errorFile.
*/
Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr);
Tcl_ReapDetachedProcs();
if (pipePtr->errorFile) {
if (TclpCloseFile(pipePtr->errorFile) != 0) {
if ( errorCode == 0 ) {
errorCode = errno;
}
}
}
result = 0;
} else {
/*
* Wrap the error file into a channel and give it to the cleanup
* routine.
*/
if (pipePtr->errorFile) {
WinFile *filePtr;
filePtr = (WinFile*)pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
TCL_READABLE);
ckfree((char *) filePtr);
} else {
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids,
pipePtr->pidPtr, errChan);
}
if (pipePtr->numPids > 0) {
ckfree((char *) pipePtr->pidPtr);
}
if (pipePtr->writeBuf != NULL) {
ckfree(pipePtr->writeBuf);
}
|
| ︙ | ︙ | |||
2477 2478 2479 2480 2481 2482 2483 |
Tcl_Pid
Tcl_WaitPid(
Tcl_Pid pid,
int *statPtr,
int options)
{
| | | > > > > > > > | 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 |
Tcl_Pid
Tcl_WaitPid(
Tcl_Pid pid,
int *statPtr,
int options)
{
ProcInfo *infoPtr = NULL, **prevPtrPtr;
DWORD flags;
Tcl_Pid result;
DWORD ret, exitCode;
PipeInit();
/*
* If no pid is specified, do nothing.
*/
if (pid == 0) {
*statPtr = 0;
return 0;
}
/*
* Find the process and cut it from the process list.
* SF Tcl Bug 859820, Backport of its fix.
* SF Tcl Bug 1381436, asking for the backport.
*
* [x] Cutting the infoPtr after the closehandle allows the
* pointer to become stale. We do it here, and compensate if the
* process was not done yet.
*/
Tcl_MutexLock(&pipeMutex);
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
if (infoPtr->hProcess == (HANDLE) pid) {
*prevPtrPtr = infoPtr->nextPtr;
break;
}
}
Tcl_MutexUnlock(&pipeMutex);
/*
* If the pid is not one of the processes we know about (we started it)
|
| ︙ | ︙ | |||
2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 |
} else {
flags = INFINITE;
}
ret = WaitForSingleObject(infoPtr->hProcess, flags);
if (ret == WAIT_TIMEOUT) {
*statPtr = 0;
if (options & WNOHANG) {
return 0;
} else {
result = 0;
}
} else if (ret == WAIT_OBJECT_0) {
GetExitCodeProcess(infoPtr->hProcess, &exitCode);
if (exitCode & 0xC0000000) {
/*
* A fatal exception occured.
*/
switch (exitCode) {
case EXCEPTION_FLT_DENORMAL_OPERAND:
case EXCEPTION_FLT_DIVIDE_BY_ZERO:
case EXCEPTION_FLT_INEXACT_RESULT:
case EXCEPTION_FLT_INVALID_OPERATION:
case EXCEPTION_FLT_OVERFLOW:
case EXCEPTION_FLT_STACK_CHECK:
case EXCEPTION_FLT_UNDERFLOW:
case EXCEPTION_INT_DIVIDE_BY_ZERO:
case EXCEPTION_INT_OVERFLOW:
| > > > > > > > > | | | | | < < < < | | | < | 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 |
} else {
flags = INFINITE;
}
ret = WaitForSingleObject(infoPtr->hProcess, flags);
if (ret == WAIT_TIMEOUT) {
*statPtr = 0;
if (options & WNOHANG) {
/*
* Re-insert the cut infoPtr back on the list.
* See [x] for explanation.
*/
Tcl_MutexLock(&pipeMutex);
infoPtr->nextPtr = procList;
procList = infoPtr;
Tcl_MutexUnlock(&pipeMutex);
return 0;
} else {
result = 0;
}
} else if (ret == WAIT_OBJECT_0) {
GetExitCodeProcess(infoPtr->hProcess, &exitCode);
if (exitCode & 0xC0000000) {
/*
* A fatal exception occured.
*/
switch (exitCode) {
case EXCEPTION_FLT_DENORMAL_OPERAND:
case EXCEPTION_FLT_DIVIDE_BY_ZERO:
case EXCEPTION_FLT_INEXACT_RESULT:
case EXCEPTION_FLT_INVALID_OPERATION:
case EXCEPTION_FLT_OVERFLOW:
case EXCEPTION_FLT_STACK_CHECK:
case EXCEPTION_FLT_UNDERFLOW:
case EXCEPTION_INT_DIVIDE_BY_ZERO:
case EXCEPTION_INT_OVERFLOW:
*statPtr = 0xC0000000 | SIGFPE;
break;
case EXCEPTION_PRIV_INSTRUCTION:
case EXCEPTION_ILLEGAL_INSTRUCTION:
*statPtr = 0xC0000000 | SIGILL;
break;
case EXCEPTION_ACCESS_VIOLATION:
case EXCEPTION_DATATYPE_MISALIGNMENT:
case EXCEPTION_ARRAY_BOUNDS_EXCEEDED:
case EXCEPTION_STACK_OVERFLOW:
case EXCEPTION_NONCONTINUABLE_EXCEPTION:
case EXCEPTION_INVALID_DISPOSITION:
case EXCEPTION_GUARD_PAGE:
case EXCEPTION_INVALID_HANDLE:
*statPtr = 0xC0000000 | SIGSEGV;
break;
case CONTROL_C_EXIT:
*statPtr = 0xC0000000 | SIGINT;
break;
default:
*statPtr = 0xC0000000 | SIGABRT;
break;
}
} else {
*statPtr = exitCode;
}
result = pid;
} else {
errno = ECHILD;
*statPtr = 0xC0000000 | ECHILD;
result = (Tcl_Pid) -1;
}
/*
* Officially close the process handle.
*/
CloseHandle(infoPtr->hProcess);
ckfree((char*)infoPtr);
return result;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 |
void
TclWinAddProcess(hProcess, id)
HANDLE hProcess; /* Handle to process */
DWORD id; /* Global process identifier */
{
ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
procPtr->hProcess = hProcess;
procPtr->dwProcessId = id;
Tcl_MutexLock(&pipeMutex);
procPtr->nextPtr = procList;
procList = procPtr;
Tcl_MutexUnlock(&pipeMutex);
}
| > > > | 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 |
void
TclWinAddProcess(hProcess, id)
HANDLE hProcess; /* Handle to process */
DWORD id; /* Global process identifier */
{
ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
PipeInit();
procPtr->hProcess = hProcess;
procPtr->dwProcessId = id;
Tcl_MutexLock(&pipeMutex);
procPtr->nextPtr = procList;
procList = procPtr;
Tcl_MutexUnlock(&pipeMutex);
}
|
| ︙ | ︙ | |||
2926 2927 2928 2929 2930 2931 2932 | /* * Alert the foreground thread. Note that we need to treat this like * a critical section so the foreground thread does not terminate * this thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&pipeMutex); | > > | > | 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 |
/*
* Alert the foreground thread. Note that we need to treat this like
* a critical section so the foreground thread does not terminate
* this thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&pipeMutex);
if (infoPtr->threadId != NULL) {
/* TIP #218. When in flight ignore the event, no one will receive it anyway */
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&pipeMutex);
}
return 0;
}
/*
|
| ︙ | ︙ | |||
3014 3015 3016 3017 3018 3019 3020 | /* * Alert the foreground thread. Note that we need to treat this like * a critical section so the foreground thread does not terminate * this thread while we are holding a mutex in the notifier code. */ Tcl_MutexLock(&pipeMutex); | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 |
/*
* Alert the foreground thread. Note that we need to treat this like
* a critical section so the foreground thread does not terminate
* this thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&pipeMutex);
if (infoPtr->threadId != NULL) {
/* TIP #218. When in flight ignore the event, no one will receive it anyway */
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&pipeMutex);
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* PipeThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
PipeThreadActionProc (instanceData, action)
ClientData instanceData;
int action;
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
/* We do not access firstPipePtr in the thread structures. This is
* not for all pipes managed by the thread, but only those we are
* watching. Removal of the filevent handlers before transfer thus
* takes care of this structure.
*/
Tcl_MutexLock(&pipeMutex);
if (action == TCL_CHANNEL_THREAD_INSERT) {
/* We can't copy the thread information from the channel when
* the channel is created. At this time the channel back
* pointer has not been set yet. However in that case the
* threadId has already been set by TclpCreateCommandChannel
* itself, so the structure is still good.
*/
PipeInit ();
if (infoPtr->channel != NULL) {
infoPtr->threadId = Tcl_GetChannelThread (infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&pipeMutex);
}
|
Changes to win/tclWinPort.h.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclWinPort.h -- * * This header file handles porting issues that occur because of * differences between Windows and Unix. It should be the only * file that contains #ifdefs to handle different flavors of OS. * * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclWinPort.h -- * * This header file handles porting issues that occur because of * differences between Windows and Unix. It should be the only * file that contains #ifdefs to handle different flavors of OS. * * Copyright (c) 1994-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinPort.h,v 1.36.2.2 2005/11/04 18:33:35 patthoyts Exp $ */ #ifndef _TCLWINPORT #define _TCLWINPORT #ifndef _TCLINT # include "tclInt.h" |
| ︙ | ︙ | |||
226 227 228 229 230 231 232 | #if TCL_UNION_WAIT # define WAIT_STATUS_TYPE union wait #else # define WAIT_STATUS_TYPE int #endif /* TCL_UNION_WAIT */ #ifndef WIFEXITED | | | | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 | #if TCL_UNION_WAIT # define WAIT_STATUS_TYPE union wait #else # define WAIT_STATUS_TYPE int #endif /* TCL_UNION_WAIT */ #ifndef WIFEXITED # define WIFEXITED(stat) (((*((int *) &(stat))) & 0xC0000000) == 0) #endif #ifndef WEXITSTATUS # define WEXITSTATUS(stat) (*((int *) &(stat))) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) ((*((int *) &(stat))) & 0xC0000000) #endif #ifndef WTERMSIG # define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) #endif #ifndef WIFSTOPPED # define WIFSTOPPED(stat) 0 #endif #ifndef WSTOPSIG # define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) #endif /* |
| ︙ | ︙ | |||
419 420 421 422 423 424 425 | /* * The following define ensures that we use the native putenv * implementation to modify the environment array. This keeps * the C level environment in synch with the system level environment. */ | | > | 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 | /* * The following define ensures that we use the native putenv * implementation to modify the environment array. This keeps * the C level environment in synch with the system level environment. */ #define USE_PUTENV 1 #define USE_PUTENV_FOR_UNSET 1 /* * Msvcrt's putenv() copies the string rather than takes ownership of it. */ #if defined(_MSC_VER) || defined(__MINGW32__) # define HAVE_PUTENV_THAT_COPIES 1 |
| ︙ | ︙ |
Changes to win/tclWinReg.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclWinReg.c -- * * This file contains the implementation of the "registry" Tcl * built-in command. This command is built as a dynamically * loadable extension in a separate DLL. * * Copyright (c) 1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclWinReg.c -- * * This file contains the implementation of the "registry" Tcl * built-in command. This command is built as a dynamically * loadable extension in a separate DLL. * * Copyright (c) 1997 by Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinReg.c,v 1.21.2.7 2007/05/15 16:08:22 dgp Exp $ */ #include <tclPort.h> #include <stdlib.h> /* * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the |
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
regWinProcs = &unicodeProcs;
} else {
regWinProcs = &asciiProcs;
}
Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
| | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
regWinProcs = &unicodeProcs;
} else {
regWinProcs = &asciiProcs;
}
Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
return Tcl_PkgProvide(interp, "registry", "1.1.5");
}
/*
*----------------------------------------------------------------------
*
* RegistryObjCmd --
*
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 |
static int
GetKeyNames(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
Tcl_Obj *patternObj) /* Optional match pattern. */
{
| > | > > > > | | | | | < < < < < < < < < > > > > > > > > | > | < > > > > > > > > > > > > > > > > > > > | > > | > | > > > > > > > > > > | > > > > > | > > | 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
static int
GetKeyNames(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
Tcl_Obj *patternObj) /* Optional match pattern. */
{
char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
DWORD subKeyCount; /* Number of subkeys to list */
DWORD maxSubKeyLen; /* Maximum string length of any subkey */
char *buffer; /* Buffer to hold the subkey name */
DWORD bufSize; /* Size of the buffer */
DWORD index; /* Position of the current subkey */
char *name; /* Subkey name */
Tcl_Obj *resultPtr; /* List of subkeys being accumulated */
int result = TCL_OK; /* Return value from this command */
Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */
if (patternObj) {
pattern = Tcl_GetString(patternObj);
} else {
pattern = NULL;
}
/* Attempt to open the key for enumeration. */
if (OpenKey(interp, keyNameObj,
KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS,
0, &key) != TCL_OK) {
return TCL_ERROR;
}
/*
* Determine how big a buffer is needed for enumerating subkeys, and
* how many subkeys there are
*/
result = (*regWinProcs->regQueryInfoKeyProc)
(key, NULL, NULL, NULL, &subKeyCount, &maxSubKeyLen, NULL, NULL,
NULL, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_NewObj());
Tcl_AppendResult(interp, "unable to query key \"",
Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
RegCloseKey(key);
return TCL_ERROR;
}
if (regWinProcs->useWide) {
buffer = ckalloc((maxSubKeyLen+1) * sizeof(WCHAR));
} else {
buffer = ckalloc(maxSubKeyLen+1);
}
/* Enumerate the subkeys */
resultPtr = Tcl_NewObj();
for (index = 0; index < subKeyCount; ++index) {
bufSize = maxSubKeyLen+1;
result = (*regWinProcs->regEnumKeyExProc)
(key, index, buffer, &bufSize, NULL, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_NewObj());
Tcl_AppendResult(interp,
"unable to enumerate subkeys of \"",
Tcl_GetString(keyNameObj),
"\": ", NULL);
AppendSystemError(interp, result);
result = TCL_ERROR;
break;
}
if (regWinProcs->useWide) {
Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize * sizeof(WCHAR), &ds);
} else {
Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize, &ds);
}
name = Tcl_DStringValue(&ds);
if (pattern && !Tcl_StringMatch(name, pattern)) {
Tcl_DStringFree(&ds);
continue;
}
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
if (result != TCL_OK) {
break;
}
}
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
}
ckfree(buffer);
RegCloseKey(key);
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
* Now open the specified key with the requested permissions. Note
* that this key must be closed by the caller.
*/
keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
if (flags & REG_CREATE) {
DWORD create;
| | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
* Now open the specified key with the requested permissions. Note
* that this key must be closed by the caller.
*/
keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf);
if (flags & REG_CREATE) {
DWORD create;
result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, NULL,
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
} else {
if (rootKey == HKEY_PERFORMANCE_DATA) {
/*
* Here we fudge it for this special root key.
* See MSDN for more info on HKEY_PERFORMANCE_DATA and
* the peculiarities surrounding it
|
| ︙ | ︙ | |||
1324 1325 1326 1327 1328 1329 1330 |
static int
BroadcastValue(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj * CONST objv[]) /* Argument values. */
{
| | | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 |
static int
BroadcastValue(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj * CONST objv[]) /* Argument values. */
{
LRESULT result, sendResult;
UINT timeout = 3000;
int len;
char *str;
Tcl_Obj *objPtr;
if ((objc != 3) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?");
|
| ︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 |
/*
* Use the ignore the result.
*/
result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
(WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);
objPtr = Tcl_NewObj();
| | | | 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 |
/*
* Use the ignore the result.
*/
result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE,
(WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult);
objPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result));
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) sendResult));
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to win/tclWinSerial.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclWinSerial.c -- * * This file implements the Windows-specific serial port functions, * and the "serial" channel driver. * * Copyright (c) 1999 by Scriptics Corp. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * Serial functionality implemented by Rolf.Schroedter@dlr.de * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | /* * tclWinSerial.c -- * * This file implements the Windows-specific serial port functions, * and the "serial" channel driver. * * Copyright (c) 1999 by Scriptics Corp. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * Serial functionality implemented by Rolf.Schroedter@dlr.de * * RCS: @(#) $Id: tclWinSerial.c,v 1.25.2.3 2005/10/05 06:33:52 hobbs Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> |
| ︙ | ︙ | |||
186 187 188 189 190 191 192 193 194 195 196 197 198 199 |
Tcl_Interp *interp, CONST char *optionName,
Tcl_DString *dsPtr));
static int SerialSetOptionProc _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp, CONST char *optionName,
CONST char *value));
static DWORD WINAPI SerialWriterThread(LPVOID arg);
/*
* This structure describes the channel type structure for command serial
* based IO.
*/
static Tcl_ChannelType serialChannelType = {
"serial", /* Type name. */
| > > > | > > | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
Tcl_Interp *interp, CONST char *optionName,
Tcl_DString *dsPtr));
static int SerialSetOptionProc _ANSI_ARGS_((ClientData instanceData,
Tcl_Interp *interp, CONST char *optionName,
CONST char *value));
static DWORD WINAPI SerialWriterThread(LPVOID arg);
static void SerialThreadActionProc _ANSI_ARGS_ ((
ClientData instanceData, int action));
/*
* This structure describes the channel type structure for command serial
* based IO.
*/
static Tcl_ChannelType serialChannelType = {
"serial", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
SerialCloseProc, /* Close proc. */
SerialInputProc, /* Input proc. */
SerialOutputProc, /* Output proc. */
NULL, /* Seek proc. */
SerialSetOptionProc, /* Set option proc. */
SerialGetOptionProc, /* Get option proc. */
SerialWatchProc, /* Set up notifier to watch the channel. */
SerialGetHandleProc, /* Get an OS handle from channel. */
NULL, /* close2proc. */
SerialBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
SerialThreadActionProc, /* thread action proc */
};
/*
*----------------------------------------------------------------------
*
* SerialInit --
*
|
| ︙ | ︙ | |||
643 644 645 646 647 648 649 650 651 652 653 654 655 656 |
TerminateThread(serialPtr->writeThread, 0);
Tcl_MutexUnlock(&serialMutex);
}
}
CloseHandle(serialPtr->writeThread);
CloseHandle(serialPtr->evWritable);
CloseHandle(serialPtr->evStartWriter);
CloseHandle(serialPtr->evStopWriter);
serialPtr->writeThread = NULL;
PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);
}
| > > | 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 |
TerminateThread(serialPtr->writeThread, 0);
Tcl_MutexUnlock(&serialMutex);
}
}
CloseHandle(serialPtr->writeThread);
CloseHandle(serialPtr->osWrite.hEvent);
DeleteCriticalSection(&serialPtr->csWrite);
CloseHandle(serialPtr->evWritable);
CloseHandle(serialPtr->evStartWriter);
CloseHandle(serialPtr->evStopWriter);
serialPtr->writeThread = NULL;
PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR);
}
|
| ︙ | ︙ | |||
1340 1341 1342 1343 1344 1345 1346 |
/*
* Alert the foreground thread. Note that we need to treat this like
* a critical section so the foreground thread does not terminate
* this thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&serialMutex);
| > > | > | 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
/*
* Alert the foreground thread. Note that we need to treat this like
* a critical section so the foreground thread does not terminate
* this thread while we are holding a mutex in the notifier code.
*/
Tcl_MutexLock(&serialMutex);
if (infoPtr->threadId != NULL) {
/* TIP #218. When in flight ignore the event, no one will receive it anyway */
Tcl_ThreadAlert(infoPtr->threadId);
}
Tcl_MutexUnlock(&serialMutex);
}
return 0;
}
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 |
Tcl_Channel
TclWinOpenSerialChannel(handle, channelName, permissions)
HANDLE handle;
char *channelName;
int permissions;
{
SerialInfo *infoPtr;
| < | | | > > > > > > > > > > < < < < < < < < | 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 |
Tcl_Channel
TclWinOpenSerialChannel(handle, channelName, permissions)
HANDLE handle;
char *channelName;
int permissions;
{
SerialInfo *infoPtr;
DWORD id;
SerialInit();
infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo));
memset(infoPtr, 0, sizeof(SerialInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
infoPtr->readable = 0;
infoPtr->writable = 1;
infoPtr->toWrite = infoPtr->writeQueue = 0;
infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
infoPtr->lastEventTime = 0;
infoPtr->lastError = infoPtr->error = 0;
infoPtr->threadId = Tcl_GetCurrentThread();
infoPtr->sysBufRead = 4096;
infoPtr->sysBufWrite = 4096;
/*
* Use the pointer to keep the channel names unique, in case
* the handles are shared between multiple channels (stdin/stdout).
*/
wsprintfA(channelName, "file%lx", (int) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
(ClientData) infoPtr, permissions);
SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite);
PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR
| PURGE_RXCLEAR);
/*
* default is blocking
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 | * Side effects: * May modify an option on a device. * *---------------------------------------------------------------------- */ static int SerialSetOptionProc(instanceData, interp, optionName, value) | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | > | | | | | | > | | | | | | | | | | | | | | | > | | | | | | | | | | > | | | | | > | | | | | | | | | > | | | | | | | | | > | | | | | | | | | > | | | | | < | | > | < < | > > | | | | | | < | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 |
* Side effects:
* May modify an option on a device.
*
*----------------------------------------------------------------------
*/
static int
SerialSetOptionProc(instanceData, interp, optionName, value)
ClientData instanceData; /* File state. */
Tcl_Interp *interp; /* For error reporting - can be NULL. */
CONST char *optionName; /* Which option to set? */
CONST char *value; /* New value for option. */
{
SerialInfo *infoPtr;
DCB dcb;
BOOL result, flag;
size_t len, vlen;
Tcl_DString ds;
CONST TCHAR *native;
int argc;
CONST char **argv;
infoPtr = (SerialInfo *) instanceData;
/*
* Parse options
*/
len = strlen(optionName);
vlen = strlen(value);
/*
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (! GetCommState(infoPtr->handle, &dcb)) {
if (interp) {
Tcl_AppendResult(interp,
"can't get comm state", (char *) NULL);
}
return TCL_ERROR;
}
native = Tcl_WinUtfToTChar(value, -1, &ds);
result = (*tclWinProcs->buildCommDCBProc)(native, &dcb);
Tcl_DStringFree(&ds);
if (result == FALSE) {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -mode: should be baud,parity,data,stop",
(char *) NULL);
}
return TCL_ERROR;
}
/* Default settings for serial communications */
dcb.fBinary = TRUE;
dcb.fErrorChar = FALSE;
dcb.fNull = FALSE;
dcb.fAbortOnError = FALSE;
if (! SetCommState(infoPtr->handle, &dcb) ) {
if (interp) {
Tcl_AppendResult(interp,
"can't set comm state", (char *) NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Option -handshake none|xonxoff|rtscts|dtrdsr
*/
if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
if (! GetCommState(infoPtr->handle, &dcb)) {
if (interp) {
Tcl_AppendResult(interp,
"can't get comm state", (char *) NULL);
}
return TCL_ERROR;
}
/*
* Reset all handshake options
* DTR and RTS are ON by default
*/
dcb.fOutX = dcb.fInX = FALSE;
dcb.fOutxCtsFlow = dcb.fOutxDsrFlow = dcb.fDsrSensitivity = FALSE;
dcb.fDtrControl = DTR_CONTROL_ENABLE;
dcb.fRtsControl = RTS_CONTROL_ENABLE;
dcb.fTXContinueOnXoff = FALSE;
/*
* Adjust the handshake limits.
* Yes, the XonXoff limits seem to influence even hardware handshake
*/
dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);
if (strnicmp(value, "NONE", vlen) == 0) {
/* leave all handshake options disabled */
} else if (strnicmp(value, "XONXOFF", vlen) == 0) {
dcb.fOutX = dcb.fInX = TRUE;
} else if (strnicmp(value, "RTSCTS", vlen) == 0) {
dcb.fOutxCtsFlow = TRUE;
dcb.fRtsControl = RTS_CONTROL_HANDSHAKE;
} else if (strnicmp(value, "DTRDSR", vlen) == 0) {
dcb.fOutxDsrFlow = TRUE;
dcb.fDtrControl = DTR_CONTROL_HANDSHAKE;
} else {
if (interp) {
Tcl_AppendResult(interp, "bad value for -handshake: ",
"must be one of xonxoff, rtscts, dtrdsr or none",
(char *) NULL);
return TCL_ERROR;
}
}
if (! SetCommState(infoPtr->handle, &dcb)) {
if (interp) {
Tcl_AppendResult(interp,
"can't set comm state", (char *) NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Option -xchar {\x11 \x13}
*/
if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
if (! GetCommState(infoPtr->handle, &dcb)) {
if (interp) {
Tcl_AppendResult(interp,
"can't get comm state", (char *) NULL);
}
return TCL_ERROR;
}
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if (argc == 2) {
dcb.XonChar = argv[0][0];
dcb.XoffChar = argv[1][0];
ckfree((char *) argv);
} else {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -xchar: should be a list of two elements",
(char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
}
if (! SetCommState(infoPtr->handle, &dcb)) {
if (interp) {
Tcl_AppendResult(interp,
"can't set comm state", (char *) NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Option -ttycontrol {DTR 1 RTS 0 BREAK 0}
*/
if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) {
int i, result = TCL_OK;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if ((argc % 2) == 1) {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -ttycontrol: should be a list of signal,value pairs",
(char *) NULL);
}
ckfree((char *) argv);
return TCL_ERROR;
}
for (i = 0; i < argc - 1; i += 2) {
if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
result = TCL_ERROR;
break;
}
if (strnicmp(argv[i], "DTR", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle, flag ?
(DWORD) SETDTR : (DWORD) CLRDTR)) {
if (interp) {
Tcl_AppendResult(interp,
"can't set DTR signal", (char *) NULL);
}
result = TCL_ERROR;
break;
}
} else if (strnicmp(argv[i], "RTS", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle, flag ?
(DWORD) SETRTS : (DWORD) CLRRTS)) {
if (interp) {
Tcl_AppendResult(interp,
"can't set RTS signal", (char *) NULL);
}
result = TCL_ERROR;
break;
}
} else if (strnicmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
if (!EscapeCommFunction(infoPtr->handle, flag ?
(DWORD) SETBREAK : (DWORD) CLRBREAK)) {
if (interp) {
Tcl_AppendResult(interp,
"can't set BREAK signal", (char *) NULL);
}
result = TCL_ERROR;
break;
}
} else {
if (interp) {
Tcl_AppendResult(interp, "bad signal for -ttycontrol: ",
"must be DTR, RTS or BREAK", (char *) NULL);
}
result = TCL_ERROR;
break;
}
}
ckfree((char *) argv);
return result;
}
/*
* Option -sysbuffer {read_size write_size}
* Option -sysbuffer read_size
*/
if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) {
/*
* -sysbuffer 4096 or -sysbuffer {64536 4096}
*/
size_t inSize = (size_t) -1, outSize = (size_t) -1;
if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) {
return TCL_ERROR;
}
if (argc == 1) {
inSize = atoi(argv[0]);
outSize = infoPtr->sysBufWrite;
} else if (argc == 2) {
inSize = atoi(argv[0]);
outSize = atoi(argv[1]);
}
ckfree((char *) argv);
if ((inSize <= 0) || (outSize <= 0)) {
if (interp) {
Tcl_AppendResult(interp,
"bad value for -sysbuffer: should be a list of one or two integers > 0",
(char *) NULL);
}
return TCL_ERROR;
}
if (! SetupComm(infoPtr->handle, inSize, outSize)) {
if (interp) {
Tcl_AppendResult(interp,
"can't setup comm buffers", (char *) NULL);
}
return TCL_ERROR;
}
infoPtr->sysBufRead = inSize;
infoPtr->sysBufWrite = outSize;
/*
* Adjust the handshake limits.
* Yes, the XonXoff limits seem to influence even hardware handshake
*/
if (! GetCommState(infoPtr->handle, &dcb)) {
if (interp) {
Tcl_AppendResult(interp,
"can't get comm state", (char *) NULL);
}
return TCL_ERROR;
}
dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2);
dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);
if (! SetCommState(infoPtr->handle, &dcb)) {
if (interp) {
Tcl_AppendResult(interp,
"can't set comm state", (char *) NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Option -pollinterval msec
*/
if ((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0)) {
if ( Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK ) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
* Option -timeout msec
*/
if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) {
int msec;
COMMTIMEOUTS tout = {0,0,0,0,0};
if ( Tcl_GetInt(interp, value, &msec) != TCL_OK ) {
return TCL_ERROR;
}
tout.ReadTotalTimeoutConstant = msec;
if (! SetCommTimeouts(infoPtr->handle, &tout)) {
if (interp) {
Tcl_AppendResult(interp,
"can't set comm timeouts", (char *) NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
return Tcl_BadChannelOption(interp, optionName,
"mode handshake pollinterval sysbuffer timeout ttycontrol xchar");
}
/*
*----------------------------------------------------------------------
*
* SerialGetOptionProc --
*
|
| ︙ | ︙ | |||
1905 1906 1907 1908 1909 1910 1911 | * The string returned by this function is in static storage and * may be reused at any time subsequent to the call. * *---------------------------------------------------------------------- */ static int SerialGetOptionProc(instanceData, interp, optionName, dsPtr) | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 |
* The string returned by this function is in static storage and
* may be reused at any time subsequent to the call.
*
*----------------------------------------------------------------------
*/
static int
SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
ClientData instanceData; /* File state. */
Tcl_Interp *interp; /* For error reporting - can be NULL. */
CONST char *optionName; /* Option to get. */
Tcl_DString *dsPtr; /* Where to store value(s). */
{
SerialInfo *infoPtr;
DCB dcb;
size_t len;
int valid = 0; /* flag if valid option parsed */
infoPtr = (SerialInfo *) instanceData;
if (optionName == NULL) {
len = 0;
} else {
len = strlen(optionName);
}
/*
* get option -mode
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-mode");
}
if ((len == 0) ||
((len > 2) && (strncmp(optionName, "-mode", len) == 0))) {
char parity;
char *stop;
char buf[2 * TCL_INTEGER_SPACE + 16];
if (! GetCommState(infoPtr->handle, &dcb)) {
if (interp) {
Tcl_AppendResult(interp,
"can't get comm state", (char *) NULL);
}
return TCL_ERROR;
}
valid = 1;
parity = 'n';
if (dcb.Parity <= 4) {
parity = "noems"[dcb.Parity];
}
stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
(dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";
wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity,
dcb.ByteSize, stop);
Tcl_DStringAppendElement(dsPtr, buf);
}
/*
* get option -pollinterval
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-pollinterval");
}
if ((len == 0) ||
((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0))) {
char buf[TCL_INTEGER_SPACE + 1];
valid = 1;
wsprintfA(buf, "%d", infoPtr->blockTime);
Tcl_DStringAppendElement(dsPtr, buf);
}
/*
* get option -sysbuffer
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-sysbuffer");
Tcl_DStringStartSublist(dsPtr);
}
if ((len == 0) ||
((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0))) {
char buf[TCL_INTEGER_SPACE + 1];
valid = 1;
wsprintfA(buf, "%d", infoPtr->sysBufRead);
Tcl_DStringAppendElement(dsPtr, buf);
wsprintfA(buf, "%d", infoPtr->sysBufWrite);
Tcl_DStringAppendElement(dsPtr, buf);
}
if (len == 0) {
Tcl_DStringEndSublist(dsPtr);
}
/*
* get option -xchar
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-xchar");
Tcl_DStringStartSublist(dsPtr);
}
if ((len == 0) ||
((len > 1) && (strncmp(optionName, "-xchar", len) == 0))) {
char buf[4];
valid = 1;
if (! GetCommState(infoPtr->handle, &dcb)) {
if (interp) {
Tcl_AppendResult(interp,
"can't get comm state", (char *) NULL);
}
return TCL_ERROR;
}
sprintf(buf, "%c", dcb.XonChar);
Tcl_DStringAppendElement(dsPtr, buf);
sprintf(buf, "%c", dcb.XoffChar);
Tcl_DStringAppendElement(dsPtr, buf);
}
if (len == 0) {
Tcl_DStringEndSublist(dsPtr);
}
/*
* get option -lasterror
* option is readonly and returned by [fconfigure chan -lasterror]
* but not returned by unnamed [fconfigure chan]
*/
if ( (len > 1) && (strncmp(optionName, "-lasterror", len) == 0) ) {
valid = 1;
SerialErrorStr(infoPtr->lastError, dsPtr);
}
/*
* get option -queue
* option is readonly and returned by [fconfigure chan -queue]
*/
if ((len > 1) && (strncmp(optionName, "-queue", len) == 0)) {
char buf[TCL_INTEGER_SPACE + 1];
COMSTAT cStat;
DWORD error;
int inBuffered, outBuffered, count;
valid = 1;
/*
* Query the pending data in Tcl's internal queues
*/
inBuffered = Tcl_InputBuffered(infoPtr->channel);
outBuffered = Tcl_OutputBuffered(infoPtr->channel);
/*
* Query the number of bytes in our output queue:
* 1. The bytes pending in the output thread
* 2. The bytes in the system drivers buffer
* The writer thread should not interfere this action.
*/
EnterCriticalSection(&infoPtr->csWrite);
ClearCommError( infoPtr->handle, &error, &cStat );
count = (int)cStat.cbOutQue + infoPtr->writeQueue;
LeaveCriticalSection(&infoPtr->csWrite);
wsprintfA(buf, "%d", inBuffered + cStat.cbInQue);
Tcl_DStringAppendElement(dsPtr, buf);
wsprintfA(buf, "%d", outBuffered + count);
Tcl_DStringAppendElement(dsPtr, buf);
}
/*
* get option -ttystatus
* option is readonly and returned by [fconfigure chan -ttystatus]
* but not returned by unnamed [fconfigure chan]
*/
if ((len > 4) && (strncmp(optionName, "-ttystatus", len) == 0)) {
DWORD status;
if (! GetCommModemStatus(infoPtr->handle, &status)) {
if (interp) {
Tcl_AppendResult(interp,
"can't get tty status", (char *) NULL);
}
return TCL_ERROR;
}
valid = 1;
SerialModemStatusStr(status, dsPtr);
}
if (valid) {
return TCL_OK;
} else {
return Tcl_BadChannelOption(interp, optionName,
"mode pollinterval lasterror queue sysbuffer ttystatus xchar");
}
}
/*
*----------------------------------------------------------------------
*
* SerialThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
SerialThreadActionProc (instanceData, action)
ClientData instanceData;
int action;
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
/* We do not access firstSerialPtr in the thread structures. This is
* not for all serials managed by the thread, but only those we are
* watching. Removal of the filevent handlers before transfer thus
* takes care of this structure.
*/
Tcl_MutexLock(&serialMutex);
if (action == TCL_CHANNEL_THREAD_INSERT) {
/* We can't copy the thread information from the channel when
* the channel is created. At this time the channel back
* pointer has not been set yet. However in that case the
* threadId has already been set by TclpCreateCommandChannel
* itself, so the structure is still good.
*/
SerialInit ();
if (infoPtr->channel != NULL) {
infoPtr->threadId = Tcl_GetChannelThread (infoPtr->channel);
}
} else {
infoPtr->threadId = NULL;
}
Tcl_MutexUnlock(&serialMutex);
}
|
Changes to win/tclWinSock.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclWinSock.c -- * * This file contains Windows-specific socket related code. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclWinSock.c -- * * This file contains Windows-specific socket related code. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinSock.c,v 1.36.2.6 2006/09/26 21:40:37 patthoyts Exp $ */ #include "tclWinInt.h" /* * Make sure to remove the redirection defines set in tclWinPort.h * that is in use in other sections of the core, except for us. |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | static Tcl_EventProc SocketEventProc; static void SocketExitHandler _ANSI_ARGS_(( ClientData clientData)); static LRESULT CALLBACK SocketProc _ANSI_ARGS_((HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)); static Tcl_EventSetupProc SocketSetupProc; | < > > > > | > > | | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 |
static Tcl_EventProc SocketEventProc;
static void SocketExitHandler _ANSI_ARGS_((
ClientData clientData));
static LRESULT CALLBACK SocketProc _ANSI_ARGS_((HWND hwnd,
UINT message, WPARAM wParam,
LPARAM lParam));
static Tcl_EventSetupProc SocketSetupProc;
static int SocketsEnabled _ANSI_ARGS_((void));
static void TcpAccept _ANSI_ARGS_((SocketInfo *infoPtr));
static Tcl_DriverBlockModeProc TcpBlockProc;
static Tcl_DriverCloseProc TcpCloseProc;
static Tcl_DriverSetOptionProc TcpSetOptionProc;
static Tcl_DriverGetOptionProc TcpGetOptionProc;
static Tcl_DriverInputProc TcpInputProc;
static Tcl_DriverOutputProc TcpOutputProc;
static Tcl_DriverWatchProc TcpWatchProc;
static Tcl_DriverGetHandleProc TcpGetHandleProc;
static int WaitForSocketEvent _ANSI_ARGS_((
SocketInfo *infoPtr, int events,
int *errorCodePtr));
static DWORD WINAPI SocketThread _ANSI_ARGS_((LPVOID arg));
static void TcpThreadActionProc _ANSI_ARGS_ ((
ClientData instanceData, int action));
/*
* This structure describes the channel type structure for TCP socket
* based IO.
*/
static Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_4, /* v4 channel */
TcpCloseProc, /* Close proc. */
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
TcpSetOptionProc, /* Set option proc. */
TcpGetOptionProc, /* Get option proc. */
TcpWatchProc, /* Set up notifier to watch this channel. */
TcpGetHandleProc, /* Get an OS handle from channel. */
NULL, /* close2proc. */
TcpBlockProc, /* Set socket into (non-)blocking mode. */
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
TcpThreadActionProc, /* thread action proc */
};
/*
*----------------------------------------------------------------------
*
* InitSockets --
*
* Initialize the socket module. Attempts to load the wsock32.dll
* library and set up the winSock function table. If successful,
* registers the event window for the socket notifier code.
*
* Assumes socketMutex is held.
*
* Results:
* None.
*
* Side effects:
* Dynamically loads wsock32.dll, and registers a new window
* class and creates a window for use in asynchronous socket
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
/*
* Check for per-thread initialization.
*/
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->socketList = NULL;
| | < | < > > > > > > < < | > | | < | | < < | < | | < < | < | 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 |
/*
* Check for per-thread initialization.
*/
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->socketList = NULL;
tsdPtr->hwnd = NULL;
tsdPtr->threadId = Tcl_GetCurrentThread();
tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
if (tsdPtr->readyEvent == NULL) {
goto unloadLibrary;
}
tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
if (tsdPtr->socketListLock == NULL) {
goto unloadLibrary;
}
tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread,
tsdPtr, 0, &id);
if (tsdPtr->socketThread == NULL) {
goto unloadLibrary;
}
SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);
/*
* Wait for the thread to signal when the window has
* been created and if it is ready to go.
*/
WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
if (tsdPtr->hwnd == NULL) {
goto unloadLibrary; /* Trouble creating the window */
}
Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
}
return;
unloadLibrary:
TclpFinalizeSockets();
FreeLibrary(winSock.hModule);
winSock.hModule = NULL;
return;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
558 559 560 561 562 563 564 | /* *---------------------------------------------------------------------- * * SocketExitHandler -- * | | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 | /* *---------------------------------------------------------------------- * * SocketExitHandler -- * * Callback invoked during app exit clean up to delete the socket * communication window and to release the WinSock DLL. * * Results: * None. * * Side effects: * None. |
| ︙ | ︙ | |||
581 582 583 584 585 586 587 |
{
Tcl_MutexLock(&socketMutex);
if (winSock.hModule) {
/*
* Make sure the socket event handling window is cleaned-up
* for, at most, this thread.
*/
| | | > > > | < | < | | < | < > | < < | | | < | | | | < | > | | | > > | > > > | > | < | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 |
{
Tcl_MutexLock(&socketMutex);
if (winSock.hModule) {
/*
* Make sure the socket event handling window is cleaned-up
* for, at most, this thread.
*/
TclpFinalizeSockets();
UnregisterClass("TclSocket", TclWinGetTclInstance());
winSock.WSACleanup();
FreeLibrary(winSock.hModule);
winSock.hModule = NULL;
}
initialized = 0;
hostnameInitialized = 0;
Tcl_MutexUnlock(&socketMutex);
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeSockets --
*
* This function is called from Tcl_FinalizeThread to finalize
* the platform specific socket subsystem.
* Also, it may be called from within this module to cleanup
* the state if unable to initialize the sockets subsystem.
*
* Results:
* None.
*
* Side effects:
* Deletes the event source and destroys the socket thread.
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeSockets()
{
ThreadSpecificData *tsdPtr;
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
if (tsdPtr->socketThread != NULL) {
if (tsdPtr->hwnd != NULL) {
PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);
/*
* Wait for the thread to exit. This ensures that we are
* completely cleaned up before we leave this function.
*/
WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
tsdPtr->hwnd = NULL;
}
CloseHandle(tsdPtr->socketThread);
tsdPtr->socketThread = NULL;
}
if (tsdPtr->readyEvent != NULL) {
CloseHandle(tsdPtr->readyEvent);
tsdPtr->readyEvent = NULL;
}
if (tsdPtr->socketListLock != NULL) {
CloseHandle(tsdPtr->socketListLock);
tsdPtr->socketListLock = NULL;
}
Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
865 866 867 868 869 870 871 |
* have to watch out for the channel being deleted out from under
* us. This may cause a redundant trip through the event loop, but
* it's simpler than trying to do unwind protection.
*/
Tcl_Time blockTime = { 0, 0 };
Tcl_SetMaxBlockTime(&blockTime);
| | | 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
* have to watch out for the channel being deleted out from under
* us. This may cause a redundant trip through the event loop, but
* it's simpler than trying to do unwind protection.
*/
Tcl_Time blockTime = { 0, 0 };
Tcl_SetMaxBlockTime(&blockTime);
mask |= TCL_READABLE|TCL_WRITABLE;
} else if (events & FD_READ) {
fd_set readFds;
struct timeval timeout;
/*
* We must check to see if data is really available, since someone
* could have consumed the data in the meantime. Turn off async
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
infoPtr->readyEvents &= ~(FD_READ);
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) SELECT, (LPARAM) infoPtr);
}
}
if (events & (FD_WRITE | FD_CONNECT)) {
mask |= TCL_WRITABLE;
}
if (mask) {
Tcl_NotifyChannel(infoPtr->channel, mask);
}
return 1;
}
| > > > > | 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 |
infoPtr->readyEvents &= ~(FD_READ);
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) SELECT, (LPARAM) infoPtr);
}
}
if (events & (FD_WRITE | FD_CONNECT)) {
mask |= TCL_WRITABLE;
if (events & FD_CONNECT && infoPtr->lastError != NO_ERROR) {
/* connect errors should also fire the readable handler. */
mask |= TCL_READABLE;
}
}
if (mask) {
Tcl_NotifyChannel(infoPtr->channel, mask);
}
return 1;
}
|
| ︙ | ︙ | |||
961 962 963 964 965 966 967 |
/* ARGSUSED */
static int
TcpCloseProc(instanceData, interp)
ClientData instanceData; /* The socket to close. */
Tcl_Interp *interp; /* Unused. */
{
SocketInfo *infoPtr = (SocketInfo *) instanceData;
| | | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 |
/* ARGSUSED */
static int
TcpCloseProc(instanceData, interp)
ClientData instanceData; /* The socket to close. */
Tcl_Interp *interp; /* Unused. */
{
SocketInfo *infoPtr = (SocketInfo *) instanceData;
/* TIP #218 */
int errorCode = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Check that WinSock is initialized; do not call it if not, to
* prevent system crashes. This can happen at exit time if the exit
* handler for WinSock ran before other exit handlers that want to
|
| ︙ | ︙ | |||
986 987 988 989 990 991 992 |
if (winSock.closesocket(infoPtr->socket) == SOCKET_ERROR) {
TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
errorCode = Tcl_GetErrno();
}
}
| | | > > > < < < < < < < < < < < | < | > > > | < < | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 |
if (winSock.closesocket(infoPtr->socket) == SOCKET_ERROR) {
TclWinConvertWSAError((DWORD) winSock.WSAGetLastError());
errorCode = Tcl_GetErrno();
}
}
/* TIP #218. Removed the code removing the structure
* from the global socket list. This is now done by
* the thread action callbacks, and only there. This
* happens before this code is called. We can free
* without fear of damanging the list.
*/
ckfree((char *) infoPtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* NewSocketInfo --
*
* This function allocates and initializes a new SocketInfo
* structure.
*
* Results:
* Returns a newly allocated SocketInfo.
*
* Side effects:
* None, except for allocation of memory.
*
*----------------------------------------------------------------------
*/
static SocketInfo *
NewSocketInfo(socket)
SOCKET socket;
{
SocketInfo *infoPtr;
infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo));
infoPtr->socket = socket;
infoPtr->flags = 0;
infoPtr->watchEvents = 0;
infoPtr->readyEvents = 0;
infoPtr->selectEvents = 0;
infoPtr->acceptEventCount = 0;
infoPtr->acceptProc = NULL;
infoPtr->lastError = 0;
/* TIP #218. Removed the code inserting the new structure
* into the global list. This is now handled in the thread
* action callbacks, and only there.
*/
infoPtr->nextPtr = NULL;
return infoPtr;
}
/*
*----------------------------------------------------------------------
*
* CreateSocket --
*
* This function opens a new socket and initializes the
* SocketInfo structure.
*
* Results:
* Returns a new SocketInfo, or NULL with an error in interp.
*
* Side effects:
* None, except for allocation of memory.
*
*----------------------------------------------------------------------
*/
static SocketInfo *
CreateSocket(interp, port, host, server, myaddr, myport, async)
Tcl_Interp *interp; /* For error reporting; can be NULL. */
|
| ︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 |
* asynchronously. */
{
u_long flag = 1; /* Indicates nonblocking mode. */
int asyncConnect = 0; /* Will be 1 if async connect is
* in progress. */
SOCKADDR_IN sockaddr; /* Socket address */
SOCKADDR_IN mysockaddr; /* Socket address for client */
| | | 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 |
* asynchronously. */
{
u_long flag = 1; /* Indicates nonblocking mode. */
int asyncConnect = 0; /* Will be 1 if async connect is
* in progress. */
SOCKADDR_IN sockaddr; /* Socket address */
SOCKADDR_IN mysockaddr; /* Socket address for client */
SOCKET sock = INVALID_SOCKET;
SocketInfo *infoPtr; /* The returned value. */
ThreadSpecificData *tsdPtr =
(ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Check that WinSock is initialized; do not call it if not, to
* prevent system crashes. This can happen at exit time if the exit
|
| ︙ | ︙ | |||
2250 2251 2252 2253 2254 2255 2256 |
if (!infoPtr->acceptProc) {
infoPtr->watchEvents = 0;
if (mask & TCL_READABLE) {
infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
}
if (mask & TCL_WRITABLE) {
| | | 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 |
if (!infoPtr->acceptProc) {
infoPtr->watchEvents = 0;
if (mask & TCL_READABLE) {
infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
}
if (mask & TCL_WRITABLE) {
infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT);
}
/*
* If there are any conditions already set, then tell the notifier to poll
* rather than block.
*/
|
| ︙ | ︙ | |||
2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 |
static DWORD WINAPI
SocketThread(LPVOID arg)
{
MSG msg;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg);
tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket",
WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg);
/*
| > > > > | < | | > > > > > > > > > > > > | | 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 |
static DWORD WINAPI
SocketThread(LPVOID arg)
{
MSG msg;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg);
/*
* Create a dummy window receiving socket events.
*/
tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket",
WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg);
/*
* Signalize thread creator that we are done creating the window.
*/
SetEvent(tsdPtr->readyEvent);
/*
* If unable to create the window, exit this thread immediately.
*/
if (tsdPtr->hwnd == NULL) {
return 1;
}
/*
* Process all messages on the socket window until WM_QUIT.
* This threads exits only when instructed to do so by the
* call to PostMessage(SOCKET_TERMINATE) in TclpFinalizeSockets().
*/
while (GetMessage(&msg, NULL, 0, 0) > 0) {
DispatchMessage(&msg);
}
/*
* This releases waiters on thread exit in TclpFinalizeSockets()
*/
SetEvent(tsdPtr->readyEvent);
return (DWORD)msg.wParam;
}
/*
*----------------------------------------------------------------------
*
* SocketProc --
|
| ︙ | ︙ | |||
2650 2651 2652 2653 2654 2655 2656 |
*/
if (!SocketsEnabled()) {
return (struct servent *) NULL;
}
return winSock.getservbyname(name, proto);
}
| | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 |
*/
if (!SocketsEnabled()) {
return (struct servent *) NULL;
}
return winSock.getservbyname(name, proto);
}
/*
*----------------------------------------------------------------------
*
* TcpThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
TcpThreadActionProc (instanceData, action)
ClientData instanceData;
int action;
{
ThreadSpecificData *tsdPtr;
SocketInfo *infoPtr = (SocketInfo *) instanceData;
int notifyCmd;
if (action == TCL_CHANNEL_THREAD_INSERT) {
/*
* Ensure that socket subsystem is initialized in this thread, or
* else sockets will not work.
*/
Tcl_MutexLock(&socketMutex);
InitSockets();
Tcl_MutexUnlock(&socketMutex);
tsdPtr = TCL_TSD_INIT(&dataKey);
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
infoPtr->nextPtr = tsdPtr->socketList;
tsdPtr->socketList = infoPtr;
SetEvent(tsdPtr->socketListLock);
notifyCmd = SELECT;
} else {
SocketInfo **nextPtrPtr;
int removed = 0;
tsdPtr = TCL_TSD_INIT(&dataKey);
/* TIP #218, Bugfix: All access to socketList has to be protected by the lock */
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == infoPtr) {
(*nextPtrPtr) = infoPtr->nextPtr;
removed = 1;
break;
}
}
SetEvent(tsdPtr->socketListLock);
/*
* This could happen if the channel was created in one thread
* and then moved to another without updating the thread
* local data in each thread.
*/
if (!removed) {
Tcl_Panic("file info ptr not on thread channel list");
}
notifyCmd = UNSELECT;
}
/*
* Ensure that, or stop, notifications for the socket occur in this thread.
*/
SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
(WPARAM) notifyCmd, (LPARAM) infoPtr);
}
|
Changes to win/tclWinTest.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclWinTest.c -- * * Contains commands for platform specific tests on Windows. * * Copyright (c) 1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > > > > > > > > > > > | > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | /* * tclWinTest.c -- * * Contains commands for platform specific tests on Windows. * * Copyright (c) 1996 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinTest.c,v 1.8.2.6 2006/03/27 23:30:54 patthoyts Exp $ */ #define USE_COMPAT_CONST #include "tclWinInt.h" /* * For TestplatformChmod on Windows */ #ifdef __WIN32__ #include <aclapi.h> #endif /* * MinGW 3.4.2 does not define this. */ #ifndef INHERITED_ACE #define INHERITED_ACE (0x10) #endif /* * Forward declarations of procedures defined later in this file: */ int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); static int TesteventloopCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST84 char **argv)); static int TestvolumetypeCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int TestwinclockCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[] )); static int TestwinsleepCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[] )); static Tcl_ObjCmdProc TestExceptionCmd; static int TestwincpuidCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[] )); static int TestplatformChmod _ANSI_ARGS_((CONST char *nativePath, int pmode)); static int TestchmodCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST84 char **argv)); /* *---------------------------------------------------------------------- * * TclplatformtestInit -- * |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 58 |
TclplatformtestInit(interp)
Tcl_Interp *interp; /* Interpreter to add commands to. */
{
/*
* Add commands for platform specific tests for Windows here.
*/
Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
| > > | | | > > > > | > | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 |
TclplatformtestInit(interp)
Tcl_Interp *interp; /* Interpreter to add commands to. */
{
/*
* Add commands for platform specific tests for Windows here.
*/
Tcl_CreateCommand(interp, "testchmod", TestchmodCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testwincpuid", TestwincpuidCmd,
(ClientData) 0, (Tcl_CmdDeleteProc*) NULL );
Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL );
Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TesteventloopCmd --
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
*/
static int
TesteventloopCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
*/
static int
TesteventloopCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST84 char **argv; /* Argument strings. */
{
static int *framePtr = NULL; /* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
while (!done) {
if (!GetMessage(&msg, NULL, 0, 0)) {
/*
* The application is exiting, so repost the quit message
* and start unwinding.
*/
| | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 |
while (!done) {
if (!GetMessage(&msg, NULL, 0, 0)) {
/*
* The application is exiting, so repost the quit message
* and start unwinding.
*/
PostQuitMessage((int)msg.wParam);
break;
}
TranslateMessage(&msg);
DispatchMessage(&msg);
}
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
return TCL_OK;
#undef VOL_BUF_SIZE
}
/*
*----------------------------------------------------------------------
*
| | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 |
return TCL_OK;
#undef VOL_BUF_SIZE
}
/*
*----------------------------------------------------------------------
*
* TestwinclockCmd --
*
* Command that returns the seconds and microseconds portions of
* the system clock and of the Tcl clock so that they can be
* compared to validate that the Tcl clock is staying in sync.
*
* Usage:
* testclock
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
CONST static FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
/* The Posix epoch, expressed as a
* Windows FILETIME */
Tcl_Time tclTime; /* Tcl clock */
FILETIME sysTime; /* System clock */
Tcl_Obj* result; /* Result of the command */
LARGE_INTEGER t1, t2;
if ( objc != 1 ) {
Tcl_WrongNumArgs( interp, 1, objv, "" );
return TCL_ERROR;
}
Tcl_GetTime( &tclTime );
GetSystemTimeAsFileTime( &sysTime );
t1.LowPart = posixEpoch.dwLowDateTime;
t1.HighPart = posixEpoch.dwHighDateTime;
t2.LowPart = sysTime.dwLowDateTime;
t2.HighPart = sysTime.dwHighDateTime;
t2.QuadPart -= t1.QuadPart;
result = Tcl_NewObj();
Tcl_ListObjAppendElement
( interp, result, Tcl_NewIntObj( (int) (t2.QuadPart / 10000000 ) ) );
Tcl_ListObjAppendElement
( interp, result,
Tcl_NewIntObj( (int) ( (t2.QuadPart / 10 ) % 1000000 ) ) );
Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.sec ) );
Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.usec ) );
Tcl_SetObjResult( interp, result );
return TCL_OK;
}
| > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
CONST static FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
/* The Posix epoch, expressed as a
* Windows FILETIME */
Tcl_Time tclTime; /* Tcl clock */
FILETIME sysTime; /* System clock */
Tcl_Obj* result; /* Result of the command */
LARGE_INTEGER t1, t2;
LARGE_INTEGER p1, p2;
if ( objc != 1 ) {
Tcl_WrongNumArgs( interp, 1, objv, "" );
return TCL_ERROR;
}
QueryPerformanceCounter( &p1 );
Tcl_GetTime( &tclTime );
GetSystemTimeAsFileTime( &sysTime );
t1.LowPart = posixEpoch.dwLowDateTime;
t1.HighPart = posixEpoch.dwHighDateTime;
t2.LowPart = sysTime.dwLowDateTime;
t2.HighPart = sysTime.dwHighDateTime;
t2.QuadPart -= t1.QuadPart;
QueryPerformanceCounter( &p2 );
result = Tcl_NewObj();
Tcl_ListObjAppendElement
( interp, result, Tcl_NewIntObj( (int) (t2.QuadPart / 10000000 ) ) );
Tcl_ListObjAppendElement
( interp, result,
Tcl_NewIntObj( (int) ( (t2.QuadPart / 10 ) % 1000000 ) ) );
Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.sec ) );
Tcl_ListObjAppendElement( interp, result, Tcl_NewIntObj( tclTime.usec ) );
Tcl_ListObjAppendElement( interp, result, Tcl_NewWideIntObj( p1.QuadPart ) );
Tcl_ListObjAppendElement( interp, result, Tcl_NewWideIntObj( p2.QuadPart ) );
Tcl_SetObjResult( interp, result );
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestwincpuidCmd --
*
* Retrieves CPU ID information.
*
* Usage:
* testwincpuid <eax>
*
* Parameters:
* eax - The value to pass in the EAX register to a CPUID instruction.
*
* Results:
* Returns a four-element list containing the values from the
* EAX, EBX, ECX and EDX registers returned from the CPUID instruction.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestwincpuidCmd( ClientData dummy,
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *CONST * objv ) /* Parameter vector */
{
int status;
int index;
unsigned int regs[4];
Tcl_Obj * regsObjs[4];
int i;
if ( objc != 2 ) {
Tcl_WrongNumArgs( interp, 1, objv, "eax" );
return TCL_ERROR;
}
if ( Tcl_GetIntFromObj( interp, objv[1], &index ) != TCL_OK ) {
return TCL_ERROR;
}
status = TclWinCPUID( (unsigned int) index, regs );
if ( status != TCL_OK ) {
Tcl_SetObjResult( interp, Tcl_NewStringObj( "operation not available",
-1 ) );
return status;
}
for ( i = 0; i < 4; ++i ) {
regsObjs[i] = Tcl_NewIntObj( (int) regs[i] );
}
Tcl_SetObjResult( interp, Tcl_NewListObj( 4, regsObjs ) );
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestwinsleepCmd --
*
* Causes this process to wait for the given number of milliseconds
* by means of a direct call to Sleep.
*
* Usage:
* testwinsleep <n>
*
* Parameters:
* n - the number of milliseconds to sleep
*
* Results:
* None.
*
* Side effects:
* Sleeps for the requisite number of milliseconds.
*
*----------------------------------------------------------------------
*/
static int
TestwinsleepCmd( ClientData clientData,
/* Unused */
Tcl_Interp* interp,
/* Tcl interpreter */
int objc,
/* Parameter count */
Tcl_Obj * CONST * objv )
/* Parameter vector */
{
int ms;
if ( objc != 2 ) {
Tcl_WrongNumArgs( interp, 1, objv, "ms" );
return TCL_ERROR;
}
if ( Tcl_GetIntFromObj( interp, objv[1], &ms ) != TCL_OK ) {
return TCL_ERROR;
}
Sleep( (DWORD) ms );
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestExceptionCmd --
*
* Causes this process to end with the named exception. Used for
* testing Tcl_WaitPid().
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
/* SMASH! */
RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
/* NOTREACHED */
return TCL_OK;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 |
/* SMASH! */
RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
/* NOTREACHED */
return TCL_OK;
}
static int
TestplatformChmod(CONST char *nativePath, int pmode)
{
SID_IDENTIFIER_AUTHORITY userSidAuthority =
{ SECURITY_WORLD_SID_AUTHORITY };
typedef DWORD (WINAPI *getSidLengthRequiredDef) ( UCHAR );
typedef BOOL (WINAPI *initializeSidDef) ( PSID,
PSID_IDENTIFIER_AUTHORITY, BYTE );
typedef PDWORD (WINAPI *getSidSubAuthorityDef) ( PSID, DWORD );
static getSidLengthRequiredDef getSidLengthRequiredProc;
static initializeSidDef initializeSidProc;
static getSidSubAuthorityDef getSidSubAuthorityProc;
static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION
| GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION;
static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE
| FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA
| FILE_WRITE_DATA | DELETE;
BYTE *secDesc = 0;
DWORD secDescLen;
const BOOL set_readOnly = !(pmode & 0222);
BOOL acl_readOnly_found = FALSE;
ACL_SIZE_INFORMATION ACLSize;
BOOL curAclPresent, curAclDefaulted;
PACL curAcl;
PACL newAcl = 0;
DWORD newAclSize;
WORD j;
SID *userSid = 0;
TCHAR *userDomain = NULL;
DWORD attr;
int res = 0;
/*
* One time initialization, dynamically load Windows NT features
*/
typedef DWORD (WINAPI *setNamedSecurityInfoADef)( IN LPSTR,
IN SE_OBJECT_TYPE, IN SECURITY_INFORMATION, IN PSID, IN PSID,
IN PACL, IN PACL );
typedef BOOL (WINAPI *getAceDef) (PACL, DWORD, LPVOID *);
typedef BOOL (WINAPI *addAceDef) ( PACL, DWORD, DWORD, LPVOID, DWORD );
typedef BOOL (WINAPI *equalSidDef) ( PSID, PSID );
typedef BOOL (WINAPI *addAccessDeniedAceDef) ( PACL, DWORD, DWORD, PSID );
typedef BOOL (WINAPI *initializeAclDef) ( PACL, DWORD, DWORD );
typedef DWORD (WINAPI *getLengthSidDef) ( PSID );
typedef BOOL (WINAPI *getAclInformationDef) (PACL, LPVOID, DWORD,
ACL_INFORMATION_CLASS );
typedef BOOL (WINAPI *getSecurityDescriptorDaclDef) (PSECURITY_DESCRIPTOR,
LPBOOL, PACL *, LPBOOL );
typedef BOOL (WINAPI *lookupAccountNameADef) ( LPCSTR, LPCSTR, PSID,
PDWORD, LPSTR, LPDWORD, PSID_NAME_USE );
typedef BOOL (WINAPI *getFileSecurityADef) ( LPCSTR, SECURITY_INFORMATION,
PSECURITY_DESCRIPTOR, DWORD, LPDWORD );
static setNamedSecurityInfoADef setNamedSecurityInfoProc;
static getAceDef getAceProc;
static addAceDef addAceProc;
static equalSidDef equalSidProc;
static addAccessDeniedAceDef addAccessDeniedAceProc;
static initializeAclDef initializeAclProc;
static getLengthSidDef getLengthSidProc;
static getAclInformationDef getAclInformationProc;
static getSecurityDescriptorDaclDef getSecurityDescriptorDaclProc;
static lookupAccountNameADef lookupAccountNameProc;
static getFileSecurityADef getFileSecurityProc;
static int initialized = 0;
if (!initialized) {
TCL_DECLARE_MUTEX(initializeMutex)
Tcl_MutexLock(&initializeMutex);
if (!initialized) {
HINSTANCE hInstance = LoadLibrary("Advapi32");
if (hInstance != NULL) {
setNamedSecurityInfoProc = (setNamedSecurityInfoADef)
GetProcAddress(hInstance, "SetNamedSecurityInfoA");
getFileSecurityProc = (getFileSecurityADef)
GetProcAddress(hInstance, "GetFileSecurityA");
getAceProc = (getAceDef)
GetProcAddress(hInstance, "GetAce");
addAceProc = (addAceDef)
GetProcAddress(hInstance, "AddAce");
equalSidProc = (equalSidDef)
GetProcAddress(hInstance, "EqualSid");
addAccessDeniedAceProc = (addAccessDeniedAceDef)
GetProcAddress(hInstance, "AddAccessDeniedAce");
initializeAclProc = (initializeAclDef)
GetProcAddress(hInstance, "InitializeAcl");
getLengthSidProc = (getLengthSidDef)
GetProcAddress(hInstance, "GetLengthSid");
getAclInformationProc = (getAclInformationDef)
GetProcAddress(hInstance, "GetAclInformation");
getSecurityDescriptorDaclProc = (getSecurityDescriptorDaclDef)
GetProcAddress(hInstance, "GetSecurityDescriptorDacl");
lookupAccountNameProc = (lookupAccountNameADef)
GetProcAddress(hInstance, "LookupAccountNameA");
getSidLengthRequiredProc = (getSidLengthRequiredDef)
GetProcAddress(hInstance, "GetSidLengthRequired");
initializeSidProc = (initializeSidDef)
GetProcAddress(hInstance, "InitializeSid");
getSidSubAuthorityProc = (getSidSubAuthorityDef)
GetProcAddress(hInstance, "GetSidSubAuthority");
if (setNamedSecurityInfoProc && getAceProc
&& addAceProc && equalSidProc && addAccessDeniedAceProc
&& initializeAclProc && getLengthSidProc
&& getAclInformationProc && getSecurityDescriptorDaclProc
&& lookupAccountNameProc && getFileSecurityProc
&& getSidLengthRequiredProc && initializeSidProc
&& getSidSubAuthorityProc)
initialized = 1;
}
if (!initialized)
initialized = -1;
}
Tcl_MutexUnlock(&initializeMutex);
}
/* Process the chmod request */
attr = GetFileAttributes(nativePath);
/* nativePath not found */
if (attr == 0xffffffff) {
res = -1;
goto done;
}
/* If no ACL API is present or nativePath is not a directory,
* there is no special handling
*/
if (initialized < 0 || !(attr & FILE_ATTRIBUTE_DIRECTORY)) {
goto done;
}
/* Set the result to error, if the ACL change is successful it will
* be reset to 0
*/
res = -1;
/*
* Read the security descriptor for the directory. Note the
* first call obtains the size of the security descriptor.
*/
if (!getFileSecurityProc(nativePath, infoBits, NULL, 0, &secDescLen)) {
if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
DWORD secDescLen2 = 0;
secDesc = (BYTE *) ckalloc(secDescLen);
if (!getFileSecurityProc(nativePath, infoBits,
(PSECURITY_DESCRIPTOR)secDesc,
secDescLen, &secDescLen2)
|| (secDescLen < secDescLen2)) {
goto done;
}
} else {
goto done;
}
}
/* Get the World SID */
userSid = (SID*) ckalloc(getSidLengthRequiredProc((UCHAR)1));
initializeSidProc( userSid, &userSidAuthority, (BYTE)1);
*(getSidSubAuthorityProc( userSid, 0)) = SECURITY_WORLD_RID;
/* If curAclPresent == false then curAcl and curAclDefaulted not valid */
if (!getSecurityDescriptorDaclProc(secDesc, &curAclPresent,
&curAcl, &curAclDefaulted))
goto done;
if (!curAclPresent || !curAcl) {
ACLSize.AclBytesInUse = 0;
ACLSize.AceCount = 0;
} else if (!getAclInformationProc(curAcl, &ACLSize, sizeof(ACLSize),
AclSizeInformation))
goto done;
/* Allocate memory for the new ACL */
newAclSize = ACLSize.AclBytesInUse + sizeof (ACCESS_DENIED_ACE)
+ getLengthSidProc(userSid) - sizeof (DWORD);
newAcl = (ACL *) ckalloc (newAclSize);
/* Initialize the new ACL */
if(!initializeAclProc(newAcl, newAclSize, ACL_REVISION)) {
goto done;
}
/* Add denied to make readonly, this will be known as a "read-only tag" */
if (set_readOnly && !addAccessDeniedAceProc(newAcl, ACL_REVISION,
readOnlyMask, userSid)) {
goto done;
}
acl_readOnly_found = FALSE;
for (j = 0; j < ACLSize.AceCount; j++) {
PACL *pACE2;
ACE_HEADER *phACE2;
if (! getAceProc (curAcl, j, (LPVOID*) &pACE2)) {
goto done;
}
phACE2 = ((ACE_HEADER *) pACE2);
/* Do NOT propagate inherited ACEs */
if (phACE2->AceFlags & INHERITED_ACE) {
continue;
}
/* Skip the "read-only tag" restriction (either added above, or it
* is being removed)
*/
if (phACE2->AceType == ACCESS_DENIED_ACE_TYPE) {
ACCESS_DENIED_ACE *pACEd = (ACCESS_DENIED_ACE *)phACE2;
if (pACEd->Mask == readOnlyMask && equalSidProc(userSid,
(PSID)&(pACEd->SidStart))) {
acl_readOnly_found = TRUE;
continue;
}
}
/* Copy the current ACE from the old to the new ACL */
if(! addAceProc (newAcl, ACL_REVISION, MAXDWORD, pACE2,
((PACE_HEADER) pACE2)->AceSize)) {
goto done;
}
}
/* Apply the new ACL */
if (set_readOnly == acl_readOnly_found
|| setNamedSecurityInfoProc((LPSTR)nativePath, SE_FILE_OBJECT,
DACL_SECURITY_INFORMATION, NULL, NULL, newAcl, NULL)
== ERROR_SUCCESS ) {
res = 0;
}
done:
if (secDesc) ckfree(secDesc);
if (newAcl) ckfree((char *)newAcl);
if (userSid) ckfree((char *)userSid);
if (userDomain) ckfree(userDomain);
if (res != 0)
return res;
/* Run normal chmod command */
return chmod(nativePath, pmode);
}
/*
*---------------------------------------------------------------------------
*
* TestchmodCmd --
*
* Implements the "testchmod" cmd. Used when testing "file" command.
* The only attribute used by the Windows platform is the user write
* flag; if this is not set, the file is made read-only. Otehrwise, the
* file is made read-write.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Changes permissions of specified files.
*
*---------------------------------------------------------------------------
*/
static int
TestchmodCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST84 char **argv; /* Argument strings. */
{
int i, mode;
char *rest;
if (argc < 2) {
usage:
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" mode file ?file ...?", NULL);
return TCL_ERROR;
}
mode = (int) strtol(argv[1], &rest, 8);
if ((rest == argv[1]) || (*rest != '\0')) {
goto usage;
}
for (i = 2; i < argc; i++) {
Tcl_DString buffer;
CONST char *translated;
translated = Tcl_TranslateFileName(interp, argv[i], &buffer);
if (translated == NULL) {
return TCL_ERROR;
}
if (TestplatformChmod(translated, mode) != 0) {
Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp),
NULL);
return TCL_ERROR;
}
Tcl_DStringFree(&buffer);
}
return TCL_OK;
}
|
Changes to win/tclWinThrd.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclWinThread.c -- * * This file implements the Windows-specific thread operations. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | /* * tclWinThread.c -- * * This file implements the Windows-specific thread operations. * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * RCS: @(#) $Id: tclWinThrd.c,v 1.24.2.12 2007/03/24 09:31:11 vasiljevic Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> /* * This is the master lock used to serialize access to other * serialization data structures. */ static CRITICAL_SECTION masterLock; static int init = 0; #define MASTER_LOCK TclpMasterLock() #define MASTER_UNLOCK TclpMasterUnlock() /* * This is the master lock used to serialize initialization and finalization * of Tcl as a whole. */ static CRITICAL_SECTION initLock; /* * allocLock is used by Tcl's version of malloc for synchronization. * For obvious reasons, cannot use any dyamically allocated storage. */ #ifdef TCL_THREADS static CRITICAL_SECTION allocLock; static Tcl_Mutex allocLockPtr = (Tcl_Mutex) &allocLock; static int allocOnce = 0; #endif /* TCL_THREADS */ /* * The joinLock serializes Create- and ExitThread. This is necessary to * prevent a race where a new joinable thread exits before the creating * thread had the time to create the necessary data structures in the |
| ︙ | ︙ | |||
81 82 83 84 85 86 87 88 89 90 91 92 93 |
struct ThreadSpecificData *prevPtr;
int flags; /* See flags below */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#endif /* TCL_THREADS */
/*
* State bits for the thread.
* WIN_THREAD_UNINIT Uninitialized. Must be zero because
* of the way ThreadSpecificData is created.
* WIN_THREAD_RUNNING Running, not waiting.
* WIN_THREAD_BLOCKED Waiting, or trying to wait.
| > > > > > > > > > > > > > > < < | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
struct ThreadSpecificData *prevPtr;
int flags; /* See flags below */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#endif /* TCL_THREADS */
/*
* Additions by AOL for specialized thread memory allocator.
*/
#if defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG)
static int once;
static DWORD tlsKey;
typedef struct allocMutex {
Tcl_Mutex tlock;
CRITICAL_SECTION wlock;
} allocMutex;
#endif
/*
* State bits for the thread.
* WIN_THREAD_UNINIT Uninitialized. Must be zero because
* of the way ThreadSpecificData is created.
* WIN_THREAD_RUNNING Running, not waiting.
* WIN_THREAD_BLOCKED Waiting, or trying to wait.
*/
#define WIN_THREAD_UNINIT 0x0
#define WIN_THREAD_RUNNING 0x1
#define WIN_THREAD_BLOCKED 0x2
/*
* The per condition queue pointers and the
* Mutex used to serialize access to the queue.
*/
typedef struct WinCondition {
CRITICAL_SECTION condLock; /* Lock to serialize queuing on the condition */
struct ThreadSpecificData *firstPtr; /* Queue pointers */
struct ThreadSpecificData *lastPtr;
} WinCondition;
/*
*----------------------------------------------------------------------
*
* TclpThreadCreate --
*
* This procedure creates a new thread.
*
* Results:
* TCL_OK if the thread could be created. The thread ID is
* returned in a parameter.
*
* Side effects:
* A new thread is created.
*
*----------------------------------------------------------------------
*/
int
TclpThreadCreate(idPtr, proc, clientData, stackSize, flags)
Tcl_ThreadId *idPtr; /* Return, the ID of the thread */
Tcl_ThreadCreateProc proc; /* Main() function of the thread */
ClientData clientData; /* The one argument to Main() */
int stackSize; /* Size of stack for the new thread */
int flags; /* Flags controlling behaviour of
* the new thread */
{
|
| ︙ | ︙ | |||
183 184 185 186 187 188 189 | * The result area is set to the exit code of the thread we * waited upon. * *---------------------------------------------------------------------- */ int | | | | | | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 |
* The result area is set to the exit code of the thread we
* waited upon.
*
*----------------------------------------------------------------------
*/
int
Tcl_JoinThread(threadId, result)
Tcl_ThreadId threadId; /* Id of the thread to wait upon */
int* result; /* Reference to the storage the result
* of the thread we wait upon will be
* written into. */
{
return TclJoinThread (threadId, result);
}
/*
*----------------------------------------------------------------------
*
* TclpThreadExit --
*
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
*----------------------------------------------------------------------
*/
Tcl_Mutex *
Tcl_GetAllocMutex()
{
#ifdef TCL_THREADS
| < < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
*----------------------------------------------------------------------
*/
Tcl_Mutex *
Tcl_GetAllocMutex()
{
#ifdef TCL_THREADS
if (!allocOnce) {
InitializeCriticalSection(&allocLock);
allocOnce = 1;
}
return &allocLockPtr;
#else
return NULL;
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeLock
*
* This procedure is used to destroy all private resources used in
* this file.
*
* Results:
* None.
*
* Side effects:
* Destroys everything private. TclpInitLock must be held
* entering this function.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeLock ()
{
MASTER_LOCK;
DeleteCriticalSection(&joinLock);
/* Destroy the critical section that we are holding! */
DeleteCriticalSection(&masterLock);
init = 0;
#ifdef TCL_THREADS
DeleteCriticalSection(&allocLock);
allocOnce = 0;
#endif
/* Destroy the critical section that we are holding! */
DeleteCriticalSection(&initLock);
}
#ifdef TCL_THREADS
/* locally used prototype */
static void FinalizeConditionEvent(ClientData data);
|
| ︙ | ︙ | |||
535 536 537 538 539 540 541 542 543 544 545 |
void
TclpThreadDataKeyInit(keyPtr)
Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
* really (DWORD **) */
{
DWORD *indexPtr;
MASTER_LOCK;
if (*keyPtr == NULL) {
indexPtr = (DWORD *)ckalloc(sizeof(DWORD));
| > > > | > > > | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 |
void
TclpThreadDataKeyInit(keyPtr)
Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
* really (DWORD **) */
{
DWORD *indexPtr;
DWORD newKey;
MASTER_LOCK;
if (*keyPtr == NULL) {
indexPtr = (DWORD *)ckalloc(sizeof(DWORD));
newKey = TlsAlloc();
if (newKey != TLS_OUT_OF_INDEXES) {
*indexPtr = newKey;
} else {
panic("TlsAlloc failed from TclpThreadDataKeyInit!"); /* this should be a fatal error */
}
*keyPtr = (Tcl_ThreadDataKey)indexPtr;
TclRememberDataKey(keyPtr);
}
MASTER_UNLOCK;
}
/*
|
| ︙ | ︙ | |||
569 570 571 572 573 574 575 576 577 578 |
VOID *
TclpThreadDataKeyGet(keyPtr)
Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
* really (DWORD **) */
{
DWORD *indexPtr = *(DWORD **)keyPtr;
if (indexPtr == NULL) {
return NULL;
} else {
| > | > > > > | 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 |
VOID *
TclpThreadDataKeyGet(keyPtr)
Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
* really (DWORD **) */
{
DWORD *indexPtr = *(DWORD **)keyPtr;
LPVOID result;
if (indexPtr == NULL) {
return NULL;
} else {
result = TlsGetValue(*indexPtr);
if ((result == NULL) && (GetLastError() != NO_ERROR)) {
panic("TlsGetValue failed from TclpThreadDataKeyGet!");
}
return result;
}
}
/*
*----------------------------------------------------------------------
*
* TclpThreadDataKeySet --
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
void
TclpThreadDataKeySet(keyPtr, data)
Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
* really (pthread_key_t **) */
VOID *data; /* Thread local storage */
{
DWORD *indexPtr = *(DWORD **)keyPtr;
| > | > > > | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 |
void
TclpThreadDataKeySet(keyPtr, data)
Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
* really (pthread_key_t **) */
VOID *data; /* Thread local storage */
{
DWORD *indexPtr = *(DWORD **)keyPtr;
BOOL success;
success = TlsSetValue(*indexPtr, (void *)data);
if (!success) {
panic("TlsSetValue failed from TclpThreadDataKeySet!");
}
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeThreadData --
*
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 633 |
void
TclpFinalizeThreadData(keyPtr)
Tcl_ThreadDataKey *keyPtr;
{
VOID *result;
DWORD *indexPtr;
| > < < < > > > > > > | > > > > > > > | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 |
void
TclpFinalizeThreadData(keyPtr)
Tcl_ThreadDataKey *keyPtr;
{
VOID *result;
DWORD *indexPtr;
BOOL success;
if (*keyPtr != NULL) {
indexPtr = *(DWORD **)keyPtr;
result = (VOID *)TlsGetValue(*indexPtr);
if (result != NULL) {
#if defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG)
if (indexPtr == &tlsKey) {
TclpFreeAllocCache(result);
return;
}
#endif
ckfree((char *)result);
success = TlsSetValue(*indexPtr, (void *)NULL);
if (!success) {
panic("TlsSetValue failed from TclpFinalizeThreadData!");
}
} else {
if (GetLastError() != NO_ERROR) {
panic("TlsGetValue failed from TclpFinalizeThreadData!");
}
}
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 672 673 |
*/
void
TclpFinalizeThreadDataKey(keyPtr)
Tcl_ThreadDataKey *keyPtr;
{
DWORD *indexPtr;
if (*keyPtr != NULL) {
indexPtr = *(DWORD **)keyPtr;
| > | > > > | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 |
*/
void
TclpFinalizeThreadDataKey(keyPtr)
Tcl_ThreadDataKey *keyPtr;
{
DWORD *indexPtr;
BOOL success;
if (*keyPtr != NULL) {
indexPtr = *(DWORD **)keyPtr;
success = TlsFree(*indexPtr);
if (!success) {
panic("TlsFree failed from TclpFinalizeThreadDataKey!");
}
ckfree((char *)indexPtr);
*keyPtr = NULL;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
708 709 710 711 712 713 714 |
WinCondition *winCondPtr; /* Per-condition queue head */
CRITICAL_SECTION *csPtr; /* Caller's Mutex, after casting */
DWORD wtime; /* Windows time value */
int timeout; /* True if we got a timeout */
int doExit = 0; /* True if we need to do exit setup */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| < < < < < < < < | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 |
WinCondition *winCondPtr; /* Per-condition queue head */
CRITICAL_SECTION *csPtr; /* Caller's Mutex, after casting */
DWORD wtime; /* Windows time value */
int timeout; /* True if we got a timeout */
int doExit = 0; /* True if we need to do exit setup */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Self initialize the two parts of the condition.
* The per-condition and per-thread parts need to be
* handled independently.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
|
| ︙ | ︙ | |||
875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 |
void
Tcl_ConditionNotify(condPtr)
Tcl_Condition *condPtr;
{
WinCondition *winCondPtr;
ThreadSpecificData *tsdPtr;
if (condPtr != NULL) {
winCondPtr = *((WinCondition **)condPtr);
/*
* Loop through all the threads waiting on the condition
* and notify them (i.e., broadcast semantics). The queue
* manipulation is guarded by the per-condition coordinating mutex.
*/
| > > > > > | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
void
Tcl_ConditionNotify(condPtr)
Tcl_Condition *condPtr;
{
WinCondition *winCondPtr;
ThreadSpecificData *tsdPtr;
if (condPtr != NULL) {
winCondPtr = *((WinCondition **)condPtr);
if (winCondPtr == NULL) {
return;
}
/*
* Loop through all the threads waiting on the condition
* and notify them (i.e., broadcast semantics). The queue
* manipulation is guarded by the per-condition coordinating mutex.
*/
|
| ︙ | ︙ | |||
927 928 929 930 931 932 933 |
*/
static void
FinalizeConditionEvent(data)
ClientData data;
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data;
| | | 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 |
*/
static void
FinalizeConditionEvent(data)
ClientData data;
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data;
tsdPtr->flags = WIN_THREAD_UNINIT;
CloseHandle(tsdPtr->condEvent);
}
/*
*----------------------------------------------------------------------
*
* TclpFinalizeCondition --
|
| ︙ | ︙ | |||
973 974 975 976 977 978 979 |
*condPtr = NULL;
}
}
/*
* Additions by AOL for specialized thread memory allocator.
*/
| < < > < < < | | > > > > > > > > > > | | | | > | > > > > > | > > | | > | < > < < > > > | > > > > > > > > > > > > > > | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 |
*condPtr = NULL;
}
}
/*
* Additions by AOL for specialized thread memory allocator.
*/
#if defined(USE_THREAD_ALLOC) && !defined(TCL_MEM_DEBUG)
Tcl_Mutex *
TclpNewAllocMutex(void)
{
struct allocMutex *lockPtr;
lockPtr = malloc(sizeof(struct allocMutex));
if (lockPtr == NULL) {
panic("could not allocate lock");
}
lockPtr->tlock = (Tcl_Mutex) &lockPtr->wlock;
InitializeCriticalSection(&lockPtr->wlock);
return &lockPtr->tlock;
}
void
TclpFreeAllocMutex(mutex)
Tcl_Mutex *mutex; /* The alloc mutex to free. */
{
allocMutex* lockPtr = (allocMutex*) mutex;
if (!lockPtr) return;
DeleteCriticalSection(&lockPtr->wlock);
free(lockPtr);
}
void *
TclpGetAllocCache(void)
{
VOID *result;
if (!once) {
/*
* We need to make sure that TclpFreeAllocCache is called
* on each thread that calls this, but only on threads that
* call this.
*/
tlsKey = TlsAlloc();
once = 1;
if (tlsKey == TLS_OUT_OF_INDEXES) {
panic("could not allocate thread local storage");
}
}
result = TlsGetValue(tlsKey);
if ((result == NULL) && (GetLastError() != NO_ERROR)) {
panic("TlsGetValue failed from TclpGetAllocCache!");
}
return result;
}
void
TclpSetAllocCache(void *ptr)
{
BOOL success;
success = TlsSetValue(tlsKey, ptr);
if (!success) {
panic("TlsSetValue failed from TclpSetAllocCache!");
}
}
void
TclpFreeAllocCache(void *ptr)
{
BOOL success;
if (ptr != NULL) {
/*
* Called by the pthread lib when a thread exits
*/
TclFreeAllocCache(ptr);
success = TlsSetValue(tlsKey, NULL);
if (!success) {
panic("TlsSetValue failed from TclpFreeAllocCache!");
}
} else if (once) {
/*
* Called by us in TclFinalizeThreadAlloc() during
* the library finalization initiated from Tcl_Finalize()
*/
success = TlsFree(tlsKey);
if (!success) {
Tcl_Panic("TlsFree failed from TclpFreeAllocCache!");
}
once = 0; /* reset for next time. */
}
}
#endif /* USE_THREAD_ALLOC */
#endif /* TCL_THREADS */
|
Changes to win/tclWinTime.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclWinTime.c -- * * Contains Windows specific versions of Tcl functions that * obtain time values from the operating system. * * Copyright 1995-1998 by Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * | | > > > > > < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
/*
* tclWinTime.c --
*
* Contains Windows specific versions of Tcl functions that
* obtain time values from the operating system.
*
* Copyright 1995-1998 by Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclWinTime.c,v 1.14.2.11 2007/04/21 19:52:15 kennykb Exp $
*/
#include "tclWinInt.h"
#define SECSPERDAY (60L * 60L * 24L)
#define SECSPERYEAR (SECSPERDAY * 365L)
#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY)
/*
* Number of samples over which to estimate the performance counter
*/
#define SAMPLES 64
/*
* The following arrays contain the day of year for the last day of
* each month, where index 1 is January.
*/
static int normalDays[] = {
-1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364
};
static int leapDays[] = {
-1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365
};
typedef struct ThreadSpecificData {
char tzName[64]; /* Time zone name */
struct tm tm; /* time information */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Data for managing high-resolution timers.
*/
typedef struct TimeInfo {
CRITICAL_SECTION cs; /* Mutex guarding this structure */
|
| ︙ | ︙ | |||
61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
HANDLE calibrationThread; /* Handle to the thread that keeps the
* virtual clock calibrated. */
HANDLE readyEvent; /* System event used to
* trigger the requesting thread
* when the clock calibration procedure
* is initialized for the first time */
HANDLE exitEvent; /* Event to signal out of an exit handler
* to tell the calibration loop to
* terminate */
/*
* The following values are used for calculating virtual time.
* Virtual time is always equal to:
* lastFileTime + (current perf counter - lastCounter)
* * 10000000 / curCounterFreq
* and lastFileTime and lastCounter are updated any time that
* virtual time is returned to a caller.
*/
| > > > > | | | | | | < < | < | > | | > | | > | | > > > > > > > > > | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 |
HANDLE calibrationThread; /* Handle to the thread that keeps the
* virtual clock calibrated. */
HANDLE readyEvent; /* System event used to
* trigger the requesting thread
* when the clock calibration procedure
* is initialized for the first time */
HANDLE exitEvent; /* Event to signal out of an exit handler
* to tell the calibration loop to
* terminate */
LARGE_INTEGER nominalFreq; /* Nominal frequency of the system
* performance counter, that is, the value
* returned from QueryPerformanceFrequency. */
/*
* The following values are used for calculating virtual time.
* Virtual time is always equal to:
* lastFileTime + (current perf counter - lastCounter)
* * 10000000 / curCounterFreq
* and lastFileTime and lastCounter are updated any time that
* virtual time is returned to a caller.
*/
ULARGE_INTEGER fileTimeLastCall;
LARGE_INTEGER perfCounterLastCall;
LARGE_INTEGER curCounterFreq;
/*
* Data used in developing the estimate of performance counter
* frequency
*/
Tcl_WideUInt fileTimeSample[SAMPLES];
/* Last 64 samples of system time */
Tcl_WideInt perfCounterSample[SAMPLES];
/* Last 64 samples of performance counter */
int sampleNo; /* Current sample number */
} TimeInfo;
static TimeInfo timeInfo = {
{ NULL },
0,
0,
(HANDLE) NULL,
(HANDLE) NULL,
(HANDLE) NULL,
#ifdef HAVE_CAST_TO_UNION
(LARGE_INTEGER) (Tcl_WideInt) 0,
(ULARGE_INTEGER) (DWORDLONG) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
#else
0,
0,
0,
0,
#endif
{ 0 },
{ 0 },
0
};
CONST static FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
/*
* Declarations for functions defined later in this file.
*/
static struct tm * ComputeGMT _ANSI_ARGS_((const time_t *tp));
static void StopCalibration _ANSI_ARGS_(( ClientData ));
static DWORD WINAPI CalibrationThread _ANSI_ARGS_(( LPVOID arg ));
static void UpdateTimeEachSecond _ANSI_ARGS_(( void ));
static void ResetCounterSamples _ANSI_ARGS_((
Tcl_WideUInt fileTime,
Tcl_WideInt perfCounter,
Tcl_WideInt perfFreq
));
static Tcl_WideInt AccumulateSample _ANSI_ARGS_((
Tcl_WideInt perfCounter,
Tcl_WideUInt fileTime
));
/*
*----------------------------------------------------------------------
*
* TclpGetSeconds --
*
* This procedure returns the number of seconds from the epoch.
|
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | * None. * *---------------------------------------------------------------------- */ int TclpGetTimeZone (currentTime) | | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclpGetTimeZone (currentTime)
Tcl_WideInt currentTime;
{
int timeZone;
tzset();
timeZone = _timezone / 60;
return timeZone;
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
*----------------------------------------------------------------------
*/
void
Tcl_GetTime(timePtr)
Tcl_Time *timePtr; /* Location to store time information. */
{
| < | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 |
*----------------------------------------------------------------------
*/
void
Tcl_GetTime(timePtr)
Tcl_Time *timePtr; /* Location to store time information. */
{
struct timeb t;
int useFtime = 1; /* Flag == TRUE if we need to fall back
* on ftime rather than using the perf
* counter */
/* Initialize static storage on the first trip through. */
/*
* Note: Outer check for 'initialized' is a performance win
* since it avoids an extra mutex lock in the common case.
*/
if ( !timeInfo.initialized ) {
TclpInitLock();
if ( !timeInfo.initialized ) {
timeInfo.perfCounterAvailable
= QueryPerformanceFrequency( &timeInfo.nominalFreq );
/*
* Some hardware abstraction layers use the CPU clock
* in place of the real-time clock as a performance counter
* reference. This results in:
* - inconsistent results among the processors on
* multi-processor systems.
|
| ︙ | ︙ | |||
292 293 294 295 296 297 298 | * frequency (perhaps in an attempt to calibrate the clock?) * we use the latter rule rather than an exact match. */ if ( timeInfo.perfCounterAvailable /* The following lines would do an exact match on * crystal frequency: | | > > > | > > > > > | | > > > > > > > > > > > > > > > > > > > > > > | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
* frequency (perhaps in an attempt to calibrate the clock?)
* we use the latter rule rather than an exact match.
*/
if ( timeInfo.perfCounterAvailable
/* The following lines would do an exact match on
* crystal frequency:
* && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt) 1193182
* && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt) 3579545
*/
&& timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000 ) {
/*
* As an exception, if every logical processor on the system
* is on the same chip, we use the performance counter anyway,
* presuming that everyone's TSC is locked to the same
* oscillator.
*/
SYSTEM_INFO systemInfo;
unsigned int regs[4];
GetSystemInfo( &systemInfo );
if ( TclWinCPUID( 0, regs ) == TCL_OK
&& regs[1] == 0x756e6547 /* "Genu" */
&& regs[3] == 0x49656e69 /* "ineI" */
&& regs[2] == 0x6c65746e /* "ntel" */
&& TclWinCPUID( 1, regs ) == TCL_OK
&& ( (regs[0] & 0x00000F00) == 0x00000F00 /* Pentium 4 */
|| ( (regs[0] & 0x00F00000) /* Extended family */
&& (regs[3] & 0x10000000) ) ) /* Hyperthread */
&& ( ( ( regs[1] & 0x00FF0000 ) >> 16 ) /* CPU count */
== systemInfo.dwNumberOfProcessors )
) {
timeInfo.perfCounterAvailable = TRUE;
} else {
timeInfo.perfCounterAvailable = FALSE;
}
}
/*
* If the performance counter is available, start a thread to
* calibrate it.
*/
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 |
}
timeInfo.initialized = TRUE;
}
TclpInitUnlock();
}
if ( timeInfo.perfCounterAvailable ) {
| < | | > | | > > | | | | | | | | | | < | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
}
timeInfo.initialized = TRUE;
}
TclpInitUnlock();
}
if ( timeInfo.perfCounterAvailable ) {
/*
* Query the performance counter and use it to calculate the
* current time.
*/
LARGE_INTEGER curCounter;
/* Current performance counter */
Tcl_WideInt curFileTime;
/* Current estimated time, expressed
* as 100-ns ticks since the Windows epoch */
static LARGE_INTEGER posixEpoch;
/* Posix epoch expressed as 100-ns ticks
* since the windows epoch */
Tcl_WideInt usecSincePosixEpoch;
/* Current microseconds since Posix epoch */
posixEpoch.LowPart = 0xD53E8000;
posixEpoch.HighPart = 0x019DB1DE;
EnterCriticalSection( &timeInfo.cs );
QueryPerformanceCounter( &curCounter );
/*
* If it appears to be more than 1.1 seconds since the last trip
* through the calibration loop, the performance counter may
* have jumped forward. (See MSDN Knowledge Base article
* Q274323 for a description of the hardware problem that makes
* this test necessary.) If the counter jumps, we don't want
* to use it directly. Instead, we must return system time.
* Eventually, the calibration loop should recover.
*/
if ( curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart
< 11 * timeInfo.curCounterFreq.QuadPart / 10 ) {
curFileTime = timeInfo.fileTimeLastCall.QuadPart
+ ( ( curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart )
* 10000000 / timeInfo.curCounterFreq.QuadPart );
timeInfo.fileTimeLastCall.QuadPart = curFileTime;
timeInfo.perfCounterLastCall.QuadPart = curCounter.QuadPart;
usecSincePosixEpoch = ( curFileTime - posixEpoch.QuadPart ) / 10;
timePtr->sec = (long) ( usecSincePosixEpoch / 1000000 );
timePtr->usec = (unsigned long ) ( usecSincePosixEpoch % 1000000 );
useFtime = 0;
}
LeaveCriticalSection( &timeInfo.cs );
}
if ( useFtime ) {
/* High resolution timer is not available. Just use ftime */
ftime(&t);
timePtr->sec = (long)t.time;
timePtr->usec = t.millitm * 1000;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
441 442 443 444 445 446 447 |
*
*----------------------------------------------------------------------
*/
char *
TclpGetTZName(int dst)
{
| | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 |
*
*----------------------------------------------------------------------
*/
char *
TclpGetTZName(int dst)
{
size_t len;
char *zone, *p;
TIME_ZONE_INFORMATION tz;
Tcl_Encoding encoding;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
char *name = tsdPtr->tzName;
/*
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 |
zone = p;
len = strlen(zone);
if (len > 3) {
len = 3;
}
}
}
| | | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 |
zone = p;
len = strlen(zone);
if (len > 3) {
len = 3;
}
}
}
Tcl_ExternalToUtf(NULL, NULL, zone, (int)len, 0, NULL, name,
sizeof(tsdPtr->tzName), NULL, NULL, NULL);
}
if (name[0] == '\0') {
if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) {
/*
* MSDN: On NT this is returned if DST is not used in
* the current TZ
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
struct tm *
TclpGetDate(t, useGMT)
TclpTime_t t;
int useGMT;
{
const time_t *tp = (const time_t *) t;
struct tm *tmPtr;
| | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 |
struct tm *
TclpGetDate(t, useGMT)
TclpTime_t t;
int useGMT;
{
const time_t *tp = (const time_t *) t;
struct tm *tmPtr;
time_t time;
if (!useGMT) {
tzset();
/*
* If we are in the valid range, let the C run-time library
* handle it. Otherwise we need to fake it. Note that this
* algorithm ignores daylight savings time before the epoch.
*/
if (*tp >= 0) {
return localtime(tp);
}
time = *tp - _timezone;
/*
* If we aren't near to overflowing the long, just add the bias and
* use the normal calculation. Otherwise we will need to adjust
* the result at the end.
*/
if (*tp < (LONG_MAX - 2 * SECSPERDAY)
|
| ︙ | ︙ | |||
575 576 577 578 579 580 581 |
time = tmPtr->tm_sec - _timezone;
tmPtr->tm_sec = (int)(time % 60);
if (tmPtr->tm_sec < 0) {
tmPtr->tm_sec += 60;
time -= 60;
}
| | | | | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 |
time = tmPtr->tm_sec - _timezone;
tmPtr->tm_sec = (int)(time % 60);
if (tmPtr->tm_sec < 0) {
tmPtr->tm_sec += 60;
time -= 60;
}
time = tmPtr->tm_min + time/60;
tmPtr->tm_min = (int)(time % 60);
if (tmPtr->tm_min < 0) {
tmPtr->tm_min += 60;
time -= 60;
}
time = tmPtr->tm_hour + time/60;
tmPtr->tm_hour = (int)(time % 24);
if (tmPtr->tm_hour < 0) {
tmPtr->tm_hour += 24;
time -= 24;
}
time /= 24;
tmPtr->tm_mday += (int)time;
tmPtr->tm_yday += (int)time;
tmPtr->tm_wday = (tmPtr->tm_wday + (int)time) % 7;
}
} else {
tmPtr = ComputeGMT(tp);
}
return tmPtr;
}
|
| ︙ | ︙ | |||
634 635 636 637 638 639 640 |
tmPtr = &tsdPtr->tm;
/*
* Compute the 4 year span containing the specified time.
*/
| | | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
tmPtr = &tsdPtr->tm;
/*
* Compute the 4 year span containing the specified time.
*/
tmp = (long)(*tp / SECSPER4YEAR);
rem = (LONG)(*tp % SECSPER4YEAR);
/*
* Correct for weird mod semantics so the remainder is always positive.
*/
if (rem < 0) {
tmp--;
|
| ︙ | ︙ | |||
701 702 703 704 705 706 707 |
tmPtr->tm_mon = --tmp;
tmPtr->tm_mday = tmPtr->tm_yday - days[tmp];
/*
* Compute day of week. Epoch started on a Thursday.
*/
| | | 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 |
tmPtr->tm_mon = --tmp;
tmPtr->tm_mday = tmPtr->tm_yday - days[tmp];
/*
* Compute day of week. Epoch started on a Thursday.
*/
tmPtr->tm_wday = (long)(*tp / SECSPERDAY) + 4;
if ((*tp % SECSPERDAY) < 0) {
tmPtr->tm_wday--;
}
tmPtr->tm_wday %= 7;
if (tmPtr->tm_wday < 0) {
tmPtr->tm_wday += 7;
}
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 | * arg -- Client data from the CreateThread call. This parameter * points to the static TimeInfo structure. * * Return value: * None. This thread embeds an infinite loop. * * Side effects: | < | | | | < | | | | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 |
* arg -- Client data from the CreateThread call. This parameter
* points to the static TimeInfo structure.
*
* Return value:
* None. This thread embeds an infinite loop.
*
* Side effects:
* At an interval of 1 s, this thread performs virtual time discipline.
*
* Note: When this thread is entered, TclpInitLock has been called
* to safeguard the static storage. There is therefore no synchronization
* in the body of this procedure.
*
*----------------------------------------------------------------------
*/
static DWORD WINAPI
CalibrationThread( LPVOID arg )
{
FILETIME curFileTime;
DWORD waitResult;
/* Get initial system time and performance counter */
GetSystemTimeAsFileTime( &curFileTime );
QueryPerformanceCounter( &timeInfo.perfCounterLastCall );
QueryPerformanceFrequency( &timeInfo.curCounterFreq );
timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime;
timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime;
ResetCounterSamples( timeInfo.fileTimeLastCall.QuadPart,
timeInfo.perfCounterLastCall.QuadPart,
timeInfo.curCounterFreq.QuadPart );
/*
* Wake up the calling thread. When it wakes up, it will release the
* initialization lock.
*/
SetEvent( timeInfo.readyEvent );
|
| ︙ | ︙ | |||
811 812 813 814 815 816 817 |
UpdateTimeEachSecond()
{
LARGE_INTEGER curPerfCounter;
/* Current value returned from
* QueryPerformanceCounter */
| < < < < < < < < | | < < | < | | | > | > > | | > > > > > | > > > > | | | | > > > > | > > > > > > > | > > > > > > > > > > < | > > > > > | | > > > | > | > > > | < > | > > > > > | > > > > > | < > | > > > > > > > > | > | > | > > > | > > > > > > > > > > | > > > > | > > > | | < < > > > > > > > | < > > > > > > > > > > > > > | > > > | > > | > | > | > | > | > > > > > > > > > > > > > > > > > > | > | | | > > > > > > | > | > | | | > | > > | > > | > > > > > > > > | < > > | | > | > > > > > > > > > > | | > | < | | < | > | | > > > > > > > > > | < > > > | | > > > > > > > > | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 |
UpdateTimeEachSecond()
{
LARGE_INTEGER curPerfCounter;
/* Current value returned from
* QueryPerformanceCounter */
FILETIME curSysTime; /* Current system time */
LARGE_INTEGER curFileTime; /* File time at the time this callback
* was scheduled. */
Tcl_WideInt estFreq; /* Estimated perf counter frequency */
Tcl_WideInt vt0; /* Tcl time right now */
Tcl_WideInt vt1; /* Tcl time one second from now */
Tcl_WideInt tdiff; /* Difference between system clock and
* Tcl time. */
Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time
* into step over 1 second */
/*
* Sample performance counter and system time.
*/
QueryPerformanceCounter( &curPerfCounter );
GetSystemTimeAsFileTime( &curSysTime );
curFileTime.LowPart = curSysTime.dwLowDateTime;
curFileTime.HighPart = curSysTime.dwHighDateTime;
EnterCriticalSection( &timeInfo.cs );
/*
* Several things may have gone wrong here that have to
* be checked for.
* (1) The performance counter may have jumped.
* (2) The system clock may have been reset.
*
* In either case, we'll need to reinitialize the circular buffer
* with samples relative to the current system time and the NOMINAL
* performance frequency (not the actual, because the actual has
* probably run slow in the first case). Our estimated frequency
* will be the nominal frequency.
*/
/*
* Store the current sample into the circular buffer of samples,
* and estimate the performance counter frequency.
*/
estFreq = AccumulateSample( curPerfCounter.QuadPart,
(Tcl_WideUInt) curFileTime.QuadPart );
/*
* We want to adjust things so that time appears to be continuous.
* Virtual file time, right now, is
*
* vt0 = 10000000 * ( curPerfCounter - perfCounterLastCall )
* / curCounterFreq
* + fileTimeLastCall
*
* Ideally, we would like to drift the clock into place over a
* period of 2 sec, so that virtual time 2 sec from now will be
*
* vt1 = 20000000 + curFileTime
*
* The frequency that we need to use to drift the counter back into
* place is estFreq * 20000000 / ( vt1 - vt0 )
*/
vt0 = 10000000 * ( curPerfCounter.QuadPart
- timeInfo.perfCounterLastCall.QuadPart )
/ timeInfo.curCounterFreq.QuadPart
+ timeInfo.fileTimeLastCall.QuadPart;
vt1 = 20000000 + curFileTime.QuadPart;
/*
* If we've gotten more than a second away from system time,
* then drifting the clock is going to be pretty hopeless.
* Just let it jump. Otherwise, compute the drift frequency and
* fill in everything.
*/
tdiff = vt0 - curFileTime.QuadPart;
if ( tdiff > 10000000 || tdiff < -10000000 ) {
timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart;
timeInfo.curCounterFreq.QuadPart = estFreq;
} else {
driftFreq = estFreq * 20000000 / ( vt1 - vt0 );
if ( driftFreq > 1003 * estFreq / 1000 ) {
driftFreq = 1003 * estFreq / 1000;
}
if ( driftFreq < 997 * estFreq / 1000 ) {
driftFreq = 997 * estFreq / 1000;
}
timeInfo.fileTimeLastCall.QuadPart = vt0;
timeInfo.curCounterFreq.QuadPart = driftFreq;
}
timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart;
LeaveCriticalSection( &timeInfo.cs );
}
/*
*----------------------------------------------------------------------
*
* ResetCounterSamples --
*
* Fills the sample arrays in 'timeInfo' with dummy values that will
* yield the current performance counter and frequency.
*
* Results:
* None.
*
* Side effects:
* The array of samples is filled in so that it appears that there
* are SAMPLES samples at one-second intervals, separated by precisely
* the given frequency.
*
*----------------------------------------------------------------------
*/
static void
ResetCounterSamples( Tcl_WideUInt fileTime,
/* Current file time */
Tcl_WideInt perfCounter,
/* Current performance counter */
Tcl_WideInt perfFreq )
/* Target performance frequency */
{
int i;
for ( i = SAMPLES-1; i >= 0; --i ) {
timeInfo.perfCounterSample[i] = perfCounter;
timeInfo.fileTimeSample[i] = fileTime;
perfCounter -= perfFreq;
fileTime -= 10000000;
}
timeInfo.sampleNo = 0;
}
/*
*----------------------------------------------------------------------
*
* AccumulateSample --
*
* Updates the circular buffer of performance counter and system
* time samples with a new data point.
*
* Results:
* None.
*
* Side effects:
* The new data point replaces the oldest point in the circular
* buffer, and the descriptive statistics are updated to accumulate
* the new point.
*
* Several things may have gone wrong here that have to
* be checked for.
* (1) The performance counter may have jumped.
* (2) The system clock may have been reset.
*
* In either case, we'll need to reinitialize the circular buffer
* with samples relative to the current system time and the NOMINAL
* performance frequency (not the actual, because the actual has
* probably run slow in the first case).
*/
static Tcl_WideInt
AccumulateSample( Tcl_WideInt perfCounter,
Tcl_WideUInt fileTime )
{
Tcl_WideUInt workFTSample; /* File time sample being removed
* from or added to the circular buffer */
Tcl_WideInt workPCSample; /* Performance counter sample being
* removed from or added to the circular
* buffer */
Tcl_WideUInt lastFTSample; /* Last file time sample recorded */
Tcl_WideInt lastPCSample; /* Last performance counter sample recorded */
Tcl_WideInt FTdiff; /* Difference between last FT and current */
Tcl_WideInt PCdiff; /* Difference between last PC and current */
Tcl_WideInt estFreq; /* Estimated performance counter frequency */
/* Test for jumps and reset the samples if we have one. */
if ( timeInfo.sampleNo == 0 ) {
lastPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo
+ SAMPLES - 1 ];
lastFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo
+ SAMPLES - 1 ];
} else {
lastPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo - 1 ];
lastFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo - 1 ];
}
PCdiff = perfCounter - lastPCSample;
FTdiff = fileTime - lastFTSample;
if ( PCdiff < timeInfo.nominalFreq.QuadPart * 9 / 10
|| PCdiff > timeInfo.nominalFreq.QuadPart * 11 / 10
|| FTdiff < 9000000
|| FTdiff > 11000000 ) {
ResetCounterSamples( fileTime, perfCounter,
timeInfo.nominalFreq.QuadPart );
return timeInfo.nominalFreq.QuadPart;
} else {
/* Estimate the frequency */
workPCSample = timeInfo.perfCounterSample[ timeInfo.sampleNo ];
workFTSample = timeInfo.fileTimeSample[ timeInfo.sampleNo ];
estFreq = 10000000 * ( perfCounter - workPCSample )
/ ( fileTime - workFTSample );
timeInfo.perfCounterSample[ timeInfo.sampleNo ] = perfCounter;
timeInfo.fileTimeSample[ timeInfo.sampleNo ] = (Tcl_WideInt) fileTime;
/* Advance the sample number */
if ( ++timeInfo.sampleNo >= SAMPLES ) {
timeInfo.sampleNo = 0;
}
return estFreq;
}
}
/*
*----------------------------------------------------------------------
*
* TclpGmtime --
*
* Wrapper around the 'gmtime' library function to make it thread
* safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes gmtime or gmtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
struct tm *
TclpGmtime( tt )
TclpTime_t_CONST tt;
{
CONST time_t *timePtr = (CONST time_t *) tt;
/* Pointer to the number of seconds
* since the local system's epoch */
/*
* The MS implementation of gmtime is thread safe because
* it returns the time in a block of thread-local storage,
* and Windows does not provide a Posix gmtime_r function.
*/
return gmtime( timePtr );
}
/*
*----------------------------------------------------------------------
*
* TclpLocaltime --
*
* Wrapper around the 'localtime' library function to make it thread
* safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes localtime or localtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
struct tm *
TclpLocaltime( tt )
TclpTime_t_CONST tt;
{
CONST time_t *timePtr = (CONST time_t *) tt;
/* Pointer to the number of seconds
* since the local system's epoch */
/*
* The MS implementation of localtime is thread safe because
* it returns the time in a block of thread-local storage,
* and Windows does not provide a Posix localtime_r function.
*/
return localtime( timePtr );
}
|