Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
| Comment: | merged with trunk at tag macosx-8-4-merge-2002-08-20-trunk |
|---|---|
| Timelines: | family | ancestors | descendants | both | macosx-8-4-merge-2002-08-20-branch | macosx-8-4-branch |
| Files: | files | file ages | folders |
| SHA1: |
354986d9c394500636d4eac4ef6490be |
| User & Date: | das 2002-08-20 20:25:23.000 |
Context
|
2002-08-21
| ||
| 12:23 | whitespace & other cleanup added support for standard MacOSX tcl package locations check-in: 2c6703cd87 user: das tags: macosx-8-4-branch | |
|
2002-08-20
| ||
| 20:25 | merged with trunk at tag macosx-8-4-merge-2002-08-20-trunk check-in: 354986d9c3 user: das tags: macosx-8-4-merge-2002-08-20-branch, macosx-8-4-branch | |
|
2002-06-28
| ||
| 22:34 | Adopting V. Darley's patch from the head. check-in: 7412baeb52 user: wolfsuit tags: macosx-8-4-branch | |
Changes
Changes to ChangeLog.
1 2 3 4 5 6 7 | 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> | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
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 SF #596034 reported by Larry Virden
<lvirden@users.sourceforge.net>.
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],
Don Porter).
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.
[Tcl 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 Tcl 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.
[Tcl 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 [Tcl 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 etting 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:
* tests/exec.test:
* tests/io.test:
* tests/ioCmd.test:
* tests/regexp.test:
* tests/regexpComp.test:
* tests/socket.test:
* tests/tcltest.test:
* tests/unixInit.test:
* tests/winDde.test:
* 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 SF 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:
* doc/CrtChannel.3:
* doc/CrtSlave.3:
* doc/Encoding.3:
* doc/Eval.3:
* doc/FileSystem.3:
* doc/Notifier.3:
* doc/OpenFileChnl.3:
* doc/ParseCmd.3:
* doc/RegExp.3:
* doc/Tcl_Main.3:
* doc/Thread.3:
* doc/TraceCmd.3:
* doc/Utf.3:
* doc/WrongNumArgs.3:
* doc/binary.n:
* doc/clock.n:
* doc/expr.n:
* doc/fconfigure.n:
* doc/glob.n:
* doc/http.n:
* doc/interp.n:
* doc/lsearch.n:
* doc/lset.n:
* 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 and
#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
* win/Makefile.in: to match current Major.minor versions
* win/makefile.bc: of the packages. Added tcltest package
* win/makefile.vc: to 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
* tests/fCmd.test: of 'file link'. Supports creation
* tests/fileName.test: of symbolic and hard links in the
* tests/fileSystem.test: native filesystems and in vfs's,
* generic/tclTest.c: when the individual filesystem
* generic/tclCmdAH.c: supports the concept.
* 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 FR #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 [FR #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 SF FR #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>
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 | * tests/proc-old.test: Improved stack trace for TCL_BREAK and TCL_CONTINUE returns from procs. Patch by Don Porter [Bug 536955]. * generic/tclExecute.c: * tests/compile.test: made bytecodes check for a catch before returning; the compiled [return] is otherwise non-catchable. | | | 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 | * tests/proc-old.test: Improved stack trace for TCL_BREAK and TCL_CONTINUE returns from procs. Patch by Don Porter [Bug 536955]. * 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: |
| ︙ | ︙ | |||
1527 1528 1529 1530 1531 1532 1533 | * unix/tclUnixPipe.c: * 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, | | | 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 | * unix/tclUnixPipe.c: * 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: |
| ︙ | ︙ | |||
1578 1579 1580 1581 1582 1583 1584 | * 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. | < < < < < < < < < < < < < < < | 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 | * 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 |
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 | * 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 | | | 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 | * 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. |
| ︙ | ︙ | |||
2109 2110 2111 2112 2113 2114 2115 | 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] | | | | | | | | | 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 | 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): |
| ︙ | ︙ | |||
2373 2374 2375 2376 2377 2378 2379 | * 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] | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > | 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 | * 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" *** ****************************************************************** |
Added ChangeLog.2001.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
2001-12-28 Jeff Hobbs <jeffh@ActiveState.com>
* library/init.tcl: make sure env(COMSPEC) on Windows is executed
with the right case, as it may otherwise fail inexplicably.
2001-12-28 Don Porter <dgp@users.sourceforge.net>
* generic/tclCkalloc.c (MemoryCmd, TclFinalizeMemorySubsystem):
Added the [memory onexit] command, intended to replace [checkmem].
* doc/DumpActiveMemory.3:
* doc/memory.n: Updated documentation for [memory] and related
matters. [Bug 487677]
* mac/tclMacBOAMain.c (Tcl_Main, CheckmemCmd): Removed all the
machinery for the [checkmem] command that is completely duplicated
by code in generic/tclCkalloc.c.
* generic/tclBinary.c:
* generic/tclListObj.c:
* generic/tclObj.c:
* generic/tclStringObj.c: Removed references to [checkmem] in
comments, referencing [memory active] instead, since it is
documented.
2001-12-28 Daniel Steffen <das@users.sourceforge.net>
* mac/tclMacInit.c:
* mac/tclMacTclCode.r: synced up tclInit features to unix/win:
implemented TclSetPreInitScript support, use of existing tclInit
proc if defined, check of default encoding dir if set. Changed
script library resource names to lowercase (i.e. same as
corresponding files). Used Tcl_JoinPath instead of string append.
Check that system encoding could be loaded before utf translating
the LibraryPath.
* mac/tclMacApplication.r:
* mac/tclMacLibrary.r:
* mac/tclMacOSA.r:
* mac/tclMacResource.r: minor version resources cleanup
2001-12-21 Mo DeJong <mdejong@users.sourceforge.net>
* unix/tcl.m4 (SC_PATH_TCLCONFIG, SC_PATH_TKCONFIG):
Search for config file using exec_prefix instead of
prefix when no --with-tcl or --with-tk argument is used. [Bug 492418]
2001-12-21 Daniel Steffen <das@users.sourceforge.net>
* unix/tcl.m4: fixed incorrect SHLIB_LD_LIBS
setting for MacOSX / Darwin.
* unix/configure: Regen.
* unix/mkLinks.tcl: improved case-insensitive
filesystem support.
* unix/mkLinks: Regen.
2001-12-19 Don Porter <dgp@users.sourceforge.net>
* unix/Makefile.in (dist): corrected use of eolFix.tcl on
working files. It should operate on distributed files. [Bug 495120]
2001-12-19 David Gravereaux <davygrvy@pobox.com>
* tools/tcl.wse.in: Fix for #495120. tcl.wse.in was
stored in cvs with improper <eol>. This resulted in
corrupted <eol> when checked-out on translating CVS
clients such as windows (CRCRLF) and mac (CRCR).
2001-12-19 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure:
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Update
SunOS 5.[0-6] target so that correct linker
options are passed to gcc or ld. [Tk Bug 220863]
2001-12-19 Mo DeJong <mdejong@users.sourceforge.net>
* unix/README: Update to account for changes
in the unix/dltest directory, the way autoconf
is run, and the new "make shell" target.
2001-12-19 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in: Rename dltest to dlpkgs to
fix problem where lib files were not getting
built because dltest/ directory already existed.
2001-12-19 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinSerial.c (SerialCheckProc): corrected time
calculations to be unsigned. (schroedter)
2001-12-18 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in: Define new dltest target that
simply does a cd to dltest/ before running make.
There is no need for the separate configure
script that was previously being used.
* unix/configure: Regen.
* unix/configure.in: Subst into dltest/Makefile.
* unix/dltest/Makefile.in: Define LIBS using
DL_LIBS, LIBS, and MATH_LIBS variables instead
of TCL_LIBS variable from tclConfig.sh.
* unix/dltest/README: Update readme to account for new
configure free implementation.
* unix/dltest/configure: Removed.
* unix/dltest/configure.in: Removed.
2001-12-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tcl.h (TCL_STUB_MAGIC): Added cast to force type to be
an int and get rid of a persistent and pointless warning with
SunPro compiler.
* generic/tclCkalloc.c (Tcl_AttemptDbCkalloc,Tcl_AttemptDbCkrealloc):
* generic/tcl.decls (Tcl_AttemptDbCkalloc,Tcl_AttemptDbCkrealloc):
Made the file parameters to these functions into CONST char *,
like they always should have been to match the other Tcl*Db* API
functions.
2001-12-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* Applied #219311 on behalf of Rolf Schroedter
<schroedter@users.sourceforge.net> to prevent fcopy on serial
ports from flooding the event queue.
2001-12-11 Miguel Sofer <msofer@users.sourceforge.net>
* doc/CrtInterp.3:
* generic/tclBasic.c: docs and comments corrections [Bug 493412]
Bug & patch by Don Porter.
2001-12-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* win/tclWinNotify.c (Tcl_FinalizeNotifier): Stop Tcl on Windows
from crashing when shutdown from a non-Tcl thread. Fixes Bug
#217982 [orig. 5804] reported by Hugh Vu and Gene Leache. I'm
not convinced that the shutdown process is right even with this,
but it was definitely wrong without...
2001-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* win/tclWinSock.c (TcpGetOptionProc): Fix for tcl bug item
#478565 reported by an unknown person. Bypasses all calls to
"gethostbyaddr" for address "0.0.0.0" to prevent delays on
Win/NT.
2001-12-12 Jeff Hobbs <jeffh@ActiveState.com>
* doc/Preserve.3: doc'd TCL_DYNAMIC use. [Patch #483989] (porter)
2001-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclIO.c (Tcl_GetsObj): Applied patch for bug #491341 as
provided by Don Porter <dgp@users.sourceforge.net>. Fixes the
assumption of having an empty Tcl_Obj to work with.
2001-12-11 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompCmds.c:
* generic/tclCompile.c:
* generic/tclExecute.c: consistency patch, to make all
instructions that pop a variable number of Tcl_Obj's off the
execution stack take the number of popped objects as first
operand. Modified *only* the new instructions
INST_LIST_INDEX_MULTI and INST_LSET_FLAT, so this has no effect
on bytecodes generated up to tcl8.4a3 inclusive.
* generic/tclExecute.c: fix debug messages in INST_LSET_LIST.
* generic/tclCompCmds.c (TclCompileLindexCmd):
* generic/tclCompExpr.c (CompileMathFuncCall): removed the last
two overestimates of the necessary stack depth for bytecodes in
the fix of [Bug 483611].
2001-12-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* unix/tclUnixPipe.c (TclpCreateProcess): Applied Don Porter's
patch fixing bug #437489.
2001-12-10 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclEvent.c:
* tests/event.test: fix background error reporting in the absence
of a bgerror proc [Bug 219142].
2001-12-10 Don Porter <dgp@users.sourceforge.net>
* doc/Access.3:
* doc/CrtChannel.3:
* doc/DString.3:
* doc/ExprLong.3:
* doc/FileSystem.3:
* doc/GetStdChan.3:
* doc/OpenFileChnl.3:
* doc/StdChannels.3:
* doc/TCL_MEM_DEBUG.3:
* doc/Tcl_Main.3:
* doc/Utf.3:
* doc/file.n:
* doc/tclsh.1: Several typo and formatting corrections discovered
during conversion to TMML. Thanks to Joe English. [Patch 490514]
* unix/mkLinks: 'make mklinks'
2001-12-10 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompCmds.c:
* generic/tclCompExpr.c:
* generic/tclCompile.c:
* generic/tclCompile.h:
* generic/tclExecute.c:
* generic/tclProc.c: fixed the calculation of the maximal stack
depth required by bytecodes [Bug 483611].
2001-12-07 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c:
* tests/trace.test: restored consistency in refCount accounting by
array traces [Bug #4484339], submitted by Don Porter.
2001-12-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/parseExpr.test, tests/for.test, tests/expr.test:
* tests/expr-old.test, tests/compile.test, tests/compExpr.test
* tests/compExpr-old.test: Kept up to date with syntax errors.
* generic/tclParseExpr.c (ParsePrimaryExpr): Rewrote to give even
better syntax errors in the fairly common case of an identifier
without decorations by guessing based on the currently available
functions. Also made messages consistent between memdebug and
ordinary builds.
2001-12-05 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c:
* tests/trace.test: new algorithm for [array get], safe when there
are traces that modify the array [Bug #449893].
2001-12-04 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/compExpr-old.test, tests/compExpr.test, tests/compile.test:
* tests/expr-old.test, tests/expr.test, tests/for.test:
* tests/while.test, tests/if.test: Rewrite to handle more specific
syntax errors.
* tests/parseExpr.test: Rewrite to get rid of dup test numbers and
handle more specific syntax errors.
* generic/tclParseExpr.c (LogSyntaxError): Added a detail message
argument to help explain what the syntax error is.
(Tcl_ParseExpr, ParseCondExpr, ParsePrimaryExpr): Added detail
messages.
(UNKNOWN_CHAR): New lexeme for characters that are always illegal
in expressions outside strings.
2001-12-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/expr.n: Various documentation improvements in relation to
the function calls. Includes fix for Bug #487704 submitted by
Devin Eyre.
2001-12-03 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc: Some install target bugs repaired along with
$(TCLSTUBLIB) added to the dependencies rather than implicit through
the dde and reg extensions which don't happen to always require it
for some build types.
2001-11-30 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c: Tcl_Preserve'ing VarTrace structures to avoid
memory corruption. Patch for [Bug: 484334] provided by Don Porter
2001-11-29 Miguel Sofer <msofer@users.sourceforge.net>
* tests/namespace.test: modified namespace-41.2, added 41.3
{knownbug} after discussion with Don Porter and Kevin Kenny.
2001-11-29 Miguel Sofer <msofer@users.sourceforge.net>
* tests/namespace.test: added namespace-41.2, a simpler test for
[Bug: 231259]
2001-11-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclBinary.c (BINARY_SCAN_MAX_CACHE, Tcl_BinaryObjCmd,
ScanNumber): Added caching scheme to reduce number of object
allocations when doing scans of large repetitive binary strings.
See comments in file for reasoning behind implementation.
Suggested by Miguel Sofer in Patch #429916, but independently
implemented.
2001-11-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/regsub.n, doc/regexp.n: Converted dangling references to
METASYNTAX section into references to the re_syntax manual page.
2001-11-27 D. Richard Hipp <drh@hwaci.com>
* win/tclWinFCmd.c: Fix a coredump in the filename normalizer
code for Win95/98.
2001-11-27 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc: Removed the Tk reference for the 'winhelp' target.
Converge at install will need to be the solution for Tk and all other
extensions.
2001-11-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/cmdAH.test (cmdAH-24.2): Made test less sensitive to OS
preemption, but perfection isn't practical [Bug 463189, reported
by Don Porter.]
* tests/switch.test (switch-9.*): Added tests to exercise more of
the argument checking. (switch-7.2,switch-7.3): Test changed
behaviour slightly.
* generic/tclCmdMZ.c (Tcl_SwitchObjCmd): Reworked argument parsing
to be stricter about what it accepts. This should make uses of
the [switch] command be more maintainable. [Bug 475397, reported
by Don Porter.]
2001-11-26 Don Porter <dgp@users.sourceforge.net>
* generic/tclIntPlatDecls.h: 'make genstubs' after changes
in 2001-11-23 commit from Daniel Steffen.
2001-11-24 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in: Add comments to better describe
TCL_EXE and when it should be available.
* win/Makefile.in: Add TCL_EXE variable to be used
by rules like `make genstubs`. Don't set TCL_LIBRARY
before running `make genstubs` since we will be running
with a tclsh from the PATH not the one we build.
2001-11-24 Mo DeJong <mdejong@users.sourceforge.net>
* win/configure: Regen.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Add comctl32.lib
to wish link libs. This change was originally added
to Tk on 2001-11-09 but was not committed to Tcl.
2001-11-23 Daniel Steffen <das@users.sourceforge.net>
* unix/Makefile.in:
* unix/configure.in:
* unix/install-sh:
* unix/mkLinks:
* unix/mkLinks.tcl:
* unix/tclLoadDyld.c:
* unix/tclMtherr.c: Mac OSX support: build system, dynamic code loading
and support for case-insensitive filesystems in mkLinks (patch #435258)
2001-11-23 Daniel Steffen <das@users.sourceforge.net>
Up-port to 8.4 of mac code changes for 8.3.3 & various new
changes for 8.4, some already backported to 8.3.4 (patch #435658)
* generic/tclObj.c: added #include to fix missing prototype errors
* generic/tcl.h: MAC_TCL: addition of ConditionalMacros.h and use of
DLLIMPORT and DLLEXPORT like on other platforms. ( => no longer need
the .exp files and can remove use of #pragma export that never worked
well)
removed line continuation in #if clause as this breaks the mac
resource compiler (note that *.r files include tcl.h)
* mac/tclMacFile.c: fixed bug in permission checking code
* mac/tclMacLoad.c: corrected utf8 handling, comparison of
package names to code fragment names changed to only match on the
length of package name, this allows for fragment names with version
numbers appended
* mac/tclMacInt.h:
* generic/tclInt.h:
* mac/tclMacTime.c:
* generic/tclIOUtil.c: moved declaration of TclpGetGMTOffset()
* mac/tclMacShLib.exp:
* mac/tclMacOSA.exp:
* mac/tclMacMSLPrefix.h: removed files
* unix/Makefile.in: removed reference to .exp files
* mac/MW_TclBuildLibHeader.h:
* mac/MW_TclBuildLibHeader.pch:
* mac/MW_TclHeaderCommon.h:
* mac/MW_TclStaticHeader.h:
* mac/MW_TclStaticHeader.pch: new precompiled header files
* mac/MW_TclAppleScriptHeader.pch:
* mac/MW_TclHeader.pch:
* mac/MW_TclTestHeader.pch:
* mac/tclMacCommonPch.h: revised precompiled header handling: now
include a common header file 'MW_TclHeaderCommon.h' from all .pch
files, the .pch files themselves now only setup #defines (e.g.
BUILD_tcl, STATIC_BUILD, TCL_DEBUG, TCL_THREADS) like in makefiles on
other platforms.
* mac/tclMac.h:
* mac/tclMacPort.h:
* mac/tclMacInt.h: use of BUILD_tcl and TCL_STORAGE_CLASS like on other
platforms, standardize #include'd files to what's done on other
platforms, removed use of #pragma export.
* mac/tcltkMacBuildSupport.sea.hqx: new archive of mac build support
files & suggested build environment directory hierarchy:
'Building MacTclTk' & 'CW Pro6 changes' readme's.
projects for MoreFiles 1.5.2 static & shared libraries.
project & sources for 'pseudoCarbonSupport', see below.
included XML versions of the projects for CW Pro5 or Pro7 users.
* mac/tclMacProjects.sea.hqx: updated mac build project files:
build support for CodeWarrior Pro6, UnivIntf 3.4 & shared runtime
libraries: the MSL libraries and MoreFiles are no longer compiled into
Tcl.shlb, all non-static binaries now use the Pro6 shared runtime
libraries and MoreFiles.shlb. These shlbs are merged into the standard
Wish and TclShell, but 3rd party applications linking with Tcl.shlb or
Tk.shlb need to setup access to them. (see the "(sh-ppc)" targets
for how to do this.)
included XML versions of the projects for CW Pro5 or Pro7 users.
use compat/strtod.c instead of MSL's strtod()
use WASTE versions of MSL for tcl test target to avoid text buffer
cutoff at 32k.
Merging the full MSL.shlb and the other shlbs into Wish & TclShell
makes them a bit larger than before, use unmerged binaries to avoid
copying the shared code with every application, e.g. when deploying
numerous Wish based droplets.
Note that using CW Pro5 to compile extensions is in principle still
possible, but need to link with Pro6 runtime libraries.
Tclapplescript now loads and runs on CFM68k.
Highly experimental "pseudoCarbon" support for Tcl only on OS 8/9:
binaries in "Build:(Carbon):" link against CarbonLib instead of
InterfaceLib, however the actual code has not been carbonized! i.e. it
will not run on OSX and may not even run properly with CarbonLib.
This should in principle allow you to build & test OS9 CFM Carbon
binaries that need to link with Tcl.shlb. On OSX you can use the
native Tcl.framework, but you have to build a MachO binary as there
is no CFM glue lib for Tcl.framework.
the library pseudoCarbonSupport.shlb manually loads the symbols
from InterfaceLib that are not in CarbonLib but are needed by the
uncarbonized code in Tcl.shlb and TclShell.
* generic/tclMain.c: MAC_TCL: workaround for broken/non-standard isatty
on MW Pro6, #include <unistd.h> instead of defining isatty
* mac/tclMacPort.h: MW Pro6 changes for MSL fcntl.h, stat.h & isatty
* mac/tclMacAppInit.c: add EXTERN to InstallConsole to enable DLL
export via the TCL_STORAGE_CLASS mechanism.
* mac/tclMacFCmd.c: fix for FSpDirectoryCopy API change
* mac/tclMacLibrary.c: emit compile time error when
TCL_REGISTER_LIBRARY and USE_TCL_STUBS are both defined at the same
time in an extension, this use is not currently supported and will
result in a crash when dynamically loading the extension.
* mac/tclMacApplication.r:
* mac/tclMacLibrary.r:
* mac/tclMacOSA.r:
* mac/tclMacResource.r: fixed obsolete copyrights/dates in version
strings; updated version strings to standard usage; added support for
'(Support Libraries)' subfolder for shared runtime libraries in
unmerged binaries; commented out demo setting of "Tcl Environment
Variables"; reorganized resources among these files to avoid
multiple copies in applications and shared libraries, the script
libraries are now no longer duplicated in Tclsh but are only included
in the resources of Tcl.shlb.
* mac/tclMacChan.c:
* mac/tclMacSock.c: cast for *BlockMode
* mac/tclMacUtil.c:
* mac/tclMacMath.h: removed obsolete hypot() definition
* generic/tclIntPlatDecls.h:
* generic/tclInt.decls:
* generic/tclStubInit.c:
* mac/tclMacNotify.c:
* mac/tclMacOSA.c:
* mac/tclMacUtil.c:
* generic/tclThreadTest.c: renamed routines conflicting with standard
Apple or MoreFiles headers (at compile or link time):
GetGlobalMouse -> GetGlobalMouseTcl
FSpGetDirectoryID -> FSpGetDirectoryIDTcl
FSpOpenResFileCompat -> FSpOpenResFileCompatTcl
FSpCreateResFileCompat -> FSpCreateResFileCompatTcl
NewThread -> NewTestThread
the renamed MoreFiles *Tcl routines are just wrappers calling into the
MoreFiles DLL.
* mac/tclMacCommonPch.h:
* mac/tclMacThrd.c:
* mac/tclMacPanic.c: removed OLDROUTINENAMES define, renamed obsolete
apple API names to modern equivalents; UH3.4 support: added #include
<ControlDefinitions.h>, updated New*Proc() calls to New*UPP().
* mac/tclMacUnix.c: added missing (Tcl_Obj ***) cast to
Tcl_ListObjGetElements call
* mac/tclMacAlloc.c: modernized TclpSysAlloc() to use temporary
memory instead of system heap memory when available (MacOS
>= 7.5 and possibly earlier, use of system heap has been
discouraged for a long time and has many disadvantages, e.g. memory
isn't paged out, and errors can very easily bring the system down);
fixed crashing bug in TclpSysRealloc() and CleanUpExitProc() where
memory was being accessed after having been deallocated; fixed
memory leak in (de)allocation code (for every block ever allocated
with TclpSysAlloc, a Ptr was leaked), if temporary memory is
available, don't track allocated memory, instead use
RecoverHandle() to get Handle from Ptr, otherwise use doubly linked
list to correctly track memory and free all allocated memory; added
new option for ConfigureMemory: MEMORY_DONT_USE_TEMPMEM, disables
use of temporary memory even when it would be available, only
necessary when writing e.g. a driver (using tcl??); increased
fraction of application heap reserved for OS routines to 512K
* compat/strftime.c:
* mac/tclMacTime.c:
* mac/tclMacPort.h:
* generic/tclInt.decls:
* generic/tclIntPlatDecls.h:
* generic/tclStubInit.c: timezone support for mac via
TclpGetTZName() like on windows, using an inverse timezone table
adapted from tclDate.c to map gmtoffset in seconds gotten from
the MacOS APIs to a timezone string, as there is no good way to get
this info from MacOS. I had to make up some unusual timezones and
arbitrarily decide on the most standard of the multiple choices
available for every timezone.
* generic/tclExecute.c: workaround for a MSL bug/misfeature: for
very small floats, MSL can return errno ERANGE but a
non-zero value ( < LDBL_MIN however)
* mac/tclMacAppInit.c: support for WASTE text library using
temporary memory, setting has no effect if WASTE is not used.
* mac/tclMacPanic.c: removed duplicate code from generic/tclPanic.c
and added that file to projects instead.
* tests/all.tcl: set tcltest::singleProcess 1 as multiple processes
are not available on the mac.
* tests/cmdAH.test: access time not available on the mac, skip the
atime touch test
* tests/appendComp.test:
* tests/cmdMZ.test:
* tests/compile.test:
* tests/exec.test:
* tests/fileName.test:
* tests/lset.test:
* tests/namespace.test:
* tests/tcltest.test: added missing cleanups/tests/catches that
caused tests to fail on the mac.
* doc/tclvars.n: doc bug, env(PWD) should be env(HOME) [Bug 463834]
2001-11-21 Don Porter <dgp@users.sourceforge.net>
* tests/trace.test (trace-8.8): Corrected test for Bug 219393.
* generic/tclBasic.c (Tcl_DeleteCommandFromToken,CallCommandTraces):
* generic/tclCmdMZ>c (Tcl_UntraceCommand): Added Tcl_Preserve and
Tcl_Release calls to prevent deletion of CommandTrace structures
until all callers are done using them, preventing memory corruption.
[Bug 453805]
2001-11-20 Kevin B. Kenny <kennykb@users.sourceforge.net>
* doc/GetTime.3 (Tcl_GetTime):
* generic/tcl.decls (Tcl_GetTime):
* generic/tclClock.c (Tcl_ClockObjCmd):
* generic/tclCompile.c (TclCleanupByteCode, TclInitByteCodeObj):
* generic/tclCmdMZ.c (Tcl_TimeObjCmd):
* generic/tclUtil.c (TclpGetTime):
* generic/tclTest.c (GetTimesCmd):
* generic/tclTimer.c (Tcl_CreateTimerHandler, TimerSetupProc,
TimerCheckProc, TimerHandlerEventProc):
* mac/tclMacNotify.c (Tcl_SetTimer):
* mac/tclMacShLib.exp (Tcl_GetTime):
* mac/tclMacTime.c (Tcl_GetTime):
* unix/tclUnixChan.c (TclUnixWaitForFile):
* unix/tclUnixEvent.c (Tcl_Sleep):
* unix/tclUnixThrd.c (Tcl_ConditionWait):
* unix/tclUnixTime.c (Tcl_GetTime):
* win/tclWinNotify.c (Tcl_Sleep):
* win/tclWinTest.c (TestwinclockCmd):
* win/tclWinTime.c (TclpGetSeconds, TclpGetClicks, Tcl_GetTime):
Changed all uses of TclpGetTime to Tcl_GetTime. Added Tcl_GetTime
to the Stubs table and the library documentation. Added a
TclpGetTime in tclUtil.c for backward compatibility of
extensions. [Patch #483500, TIP#73]
* generic/tclCmdMZ.c (Tcl_TimeObjCmd): Corrected an error in the
[time] command that caused incorrect results to be returned if the
total duration of all iterations exceeded 2**31 microseconds.
[Bug #478847]
* generic/tclInt.decls:
* generic/tclInt.h:
* generic/tclStubInit.h: Reran 'make genstubs'
2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c
* generic/tclCompile.h:
* generic/tclExecute.c: moving all code relative to bytecodes from
tclBasic.c to tclExecute.c - the functions RecordTracebackInfo and
Tcl_ExprObj went to tclExecute.c, and new interface function was
defined (TclCompEvalObj).
The final objective of this sequence of moves is to provide a
clean, clear-cut interface between Tcl's core and the
compiler/engine subsystem.
2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c
* generic/tclCompile.h:
* generic/tclExecute.c: factoring out of common code in tclBasic.c
(new function TclInterpReady defined: it resets the interp's
result, then checks that it hasn't been deleted and that the
nesting level is acceptable). Passed the responsibility of calling
it to the *callers* of TclEvalObjvInternal.
2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c
* generic/tclExecute.c: a better variant of the previous-to-last
commit (restoring numLevels computations). The managing of the
levels now has to be done by the *callers* of TclEvalObjvInternal
2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: missing variable declaration under
TCL_COMPILE_DEBUG.
2001-11-20 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c:
* generic/tclProc.c: restoring the computations of iPtr->numLevels
to the original logic (previous to buggy modifs on 2001-11-16).
2001-11-20 Jeff Hobbs <jeffh@ActiveState.com>
* tools/eolFix.tcl (new-file):
* unix/Makefile.in: added EOL correction for Windows bat files to
dist target. [Bug #219409] (davygrvy)
* unix/tclUnixInit.c (TclpSetInitialEncodings): update of patch
from 2001-11-16 that uses the old Tcl encoding check mechanism as
a fallback to the original. Also added a TCL_DEFAULT_ENCODING
#define (defaults to iso8859-1). Tcl will first try setlocale and
nl_langinfo, and if that fails, guess based on certain LANG|LC_*
env vars. [Patch #418645]
2001-11-19 David Gravereaux <davygrvy@pobox.com>
* win/buildall.vc.bat: Added useful comments.
2001-11-19 Miguel Sofer <msofer@users.sourceforge.net>
* tests/compile.test: added a test for bug [Bug 483309]
2001-11-19 Vince Darley <vincentdarley@users.sourceforge.net>
* win/tclWinFile.c:
* win/tclWinFCmd.c:
* win/tclWin32Dll.c:
* doc/file.n:
* tests/winFCmd.test: improved speed of file normalization
for Win95/98, and clarified docs on differences in file
normalization between NT/2000 and the older operating systems.
Added test to ensure normalization is correct.
2001-11-19 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c:
* generic/tclParse.c: Code reorganisation. Moved all evaluation
functions from tclParse.c to tclBasic.c, so that now tclParse.c
deals exclusively with parsing and all evaluations are done by
code in tclBasic.c. The functions moved are: TclEvalObjvInternal,
Tcl_EvalObjv, Tcl_LogCommandInfo, Tcl_EvalTokensStandard,
Tcl_EvalTokens, Tcl_EvalEx, Tcl_Eval, Tcl_EvalObj and
Tcl_GlobalEvalObj.
2001-11-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/trace.test (trace-8.8): Added adapted version of Bug
#219393 as new test; the test won't reliably show up the old
problem unless it is being run under something like Purify, but
something is better than nothing...
* generic/tclVar.c (Tcl_TraceVar2, Tcl_UntraceVar2): Added missing
mask bits for trace result type and a check for a nonsense flag
combination.
* generic/tclCmdMZ.c (TraceVarProc): Added missing test for NULL
when deleting a trace that doesn't cause an error.
* doc/TraceVar.3: Added documentation for change due to TIP#68.
* generic/tclCmdMZ.c (TraceVarInfo): Removed problematic errMsg
field from structure.
(TraceVarProc): Removed references to errMsg field and changed
handling of errors so that they returned a Tcl_Obj* containing the
error string. This minimizes the number of calls to the memory
management subsystem.
(TclTraceCommandObjCmd, TraceCommandProc): Removed references to
errMsg field which was never used in command traces in any case.
(Tcl_TraceObjCmd, TclTraceVariableObjCmd): Removed references to
errMsg field and made variable traces register with
TCL_TRACE_RESULT_OBJECT bit set.
* generic/tcl.h (TCL_TRACE_RESULT_DYNAMIC,TCL_TRACE_RESULT_OBJECT):
New constants to define how to handle the strings returned from
trace callbacks [TIP#68]
* generic/tclVar.c (CallTraces, Tcl_GetVar2Ex, TclGetIndexedScalar,
TclGetElementOfIndexedArray, Tcl_SetVar2Ex, TclSetIndexedScalar,
TclSetElementOfIndexedArray, Tcl_UnsetVar2, Tcl_ArrayObjCmd,
TclDeleteVars, TclDeleteCompiledLocalVars, DeleteArray,
TclVarTraceExists): Support for those new trace flags.
2001-11-19 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompCmds.c: patch for [Bug 483309] (petasis).
2001-11-16 Kevin B. Kenny <kennykb@users.sourceforge.net>
* generic/tclListObj.c: removed a C++-style comment that
was inadvertently left in the source code.
2001-11-16 Jeff Hobbs <jeffh@ActiveState.com>
* tests/interp.test:
* generic/tclInterp.c (SlaveObjCmd): Corrected argument checking
for '$interp alias|aliases|issafe'. [Patch #479560] (thoyts, hobbs)
* unix/tclUnixInit.c: added HAVE_LANGINFO code block.
* unix/configure: regened
* unix/configure.in: added SC_ENABLE_LANGINFO call
* unix/tcl.m4: made SHLIB_LD_LIBS='${LIBS}' for FreeBSD* (meyer)
Added modified version of Wagner patch to make use of nl_langinfo
where possible to determine Unix platform encoding, instead of the
inflexible built-in system. This is used by default when
possible, and can be disabled with --enable-langinfo=no.
[Patch #418645] (hobbs, wagner)
2001-11-16 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompile.h:
* generic/tclExecute.c:
* generic/tclObj.c: moved Tcl_GetCommandFromObj and all defining
code for tclCmdNameType objects to tclObj.c (from tclExecute.c).
This code has nothing to do with bytecodes.
2001-11-16 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c:
* generic/tclCompile.h:
* generic/tclExecute.c:
* generic/tclParse.c:
* generic/tclProc.c:
* tests/stack.test: consolidation of duplicated code (in
TclExecuteByteCode and EvalObjv); renaming of EvalObjv to
TclEvalObjv as it is not static anymore; restored consistency of
level counts between compiled and directly evaled code.
[Bug 480896]
2001-11-12 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc:
* win/rules.vc: Small bug fixes.
* win/README: added some docs pointing to the docs in makefile.vc
for it's use.
2001-10-17 Kevin B. Kenny <kennykb@users.sourceforge.net>
* doc/lappend.n:
* doc/lindex.n:
* doc/linsert.n:
* doc/list.n:
* doc/llength.n:
* doc/lrange.n:
* doc/lsearch.n:
* doc/lset.n (new-file):
* doc/lsort.n:
* generic/tclBasic.c (builtInCmds, Tcl_EvalObjEx):
* generic/tclCmdIL.c (Tcl_LindexObjCmd, Tcl_LindexList):
(Tcl_LindexFlat, Tcl_LsetObjCmd):
* generic/tclCompCmds.c (Tcl_CompileLindexCmd, Tcl_CompileLsetCmd):
* generic/tclCompile.c:
* generic/tclCompile.h:
* generic/tclExecute.c (TclExecuteByteCode):
* generic/tclInt.decls:
* generic/tclInt.h:
* generic/tclIntDecls.h:
* generic/tclListObj.c (TclLsetList, TclLsetFlat, TclSetListElement):
* generic/tclObj.c (TclInitObjSubsystem):
* generic/tclStubInit.c:
* generic/tclTestObj.c (TestobjCmd):
* generic/tclUtil.c (TclGetIntForIndex, SetEndOffsetFromAny):
* generic/tclVar.c (Tcl_LappendObjCmd):
* tests/lindex.test:
* tests/lset.test (new-file):
* tests/lsetComp.test (new-file):
* tests/obj.test:
* tests/string.test:
* tests/stringComp.test:
Reference implementation of TIP's #22, #33 and #45. Adds the
ability of the [lindex] command to have multiple index arguments,
and adds the [lset] command. Both commands are byte-code compiled.
[Patch #471874] (work by Kenny, commited by Hobbs)
2001-11-12 David Gravereaux <davygrvy@pobox.com>
* win/buildall.vc.bat(new):
* win/makefile.vc: Small fix with deriving the "OriginalFilename"
string in the .rc scripts. Added a quick batchfile for building
the entire thing.
2001-11-12 Jeff Hobbs <jeffh@ActiveState.com>
* doc/FileSystem.3:
* doc/file.n:
* doc/tcltest.n: converted use of \' to more reasonable format.
2001-11-10 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in:
* win/Makefile.in: Add "make gdb" target. This target
can run tclsh inside either gdb or insight.
2001-11-10 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc: Added a check to make sure one runs the makefile
from the /win directory only.
* win/mkd.bat:
* win/rmd.bat: Changes from Llyod Lim for better stability.
[Patch #456759]
2001-11-09 David Gravereaux <davygrvy@pobox.com>
* win/makefile.vc:
* win/tcl.dsp: winhelp target fixes for non-NT systems. It
seems NMAKE under these remembers changed directories during
commands. A new tcltest feature from Peter Spjuth
<peter.spjuth@space.se> to specify a pattern file from the
commandline and redirecting output to a file when not under
NT with it's scrollback console. Then it replays it, piped
through more. Added 2 new static "configurations" to tcl.dsp.
I could keep adding more, but I think we should leave it up to
the user for customizing it.
Sticky-points left: 'profile' option.
2001-11-09 Jeff Hobbs <jeffh@ActiveState.com>
* doc/FileSystem.3:
* doc/StdChannels.3:
* doc/file.n:
* doc/tcltest.n:
* tools/man2help.tcl:
* tools/man2help2.tcl: fixed winhelp generation problems
[Patch #480268]
* unix/configure:
* unix/tcl.m4: added -lc to AIX libs, fixed path to ldAix
2001-11-09 Don Porter <dgp@users.sourceforge.net>
* tests/var.test:
* generic/tclVar.c: Corrected bug in [global] when dealing
with variable names matching :*. [Bug 480176]
2001-11-08 Mo DeJong <mdejong@users.sourceforge.net>
Fixup stack size under OSF1. [Tcl patch 474790]
* unix/configure: Regen.
* unix/tcl.m4: Add HAVE_PTHREAD_ATTR_SETSTACKSIZE define
to EXTRA_CFLAGS to adjust initial stack size.
2001-11-08 Mo DeJong <mdejong@users.sourceforge.net>
Enable thread support under FreeBSD. [Tcl bug 473708]
* unix/configure: Regen.
* unix/tcl.m4 (SC_ENABLE_THREADS): Check for pthread functions
in libc_r and enable thread support if found.
* unix/dltest/Makefile.in: Set SHLIB_LD_LIBS and use it in
the Makefile to properly link a shared library.
2001-11-08 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in:
* unix/dltest/Makefile.in:
Avoid adding libc to the LIBS variable since it
is not needed when linking with CC. If required
when linking with LD it should be done on a case
by case basis in tcl.m4.
2001-11-08 David Gravereaux <davygrvy@pobox.com>
* win/rules.vc:
* win/makefile.vc: Fixed install target to adjust for the
different build types. Added a 'linkexten' option to link the
win extensions inside the shell when built static. Placed
win/tclAppInit.c patch in SF patch DB for approval. 'profile'
option not hooked in yet. Everything else know is done.
* win/tcl.dsp(new):
* win/tcl.dsw(new): Simple MsDev stub project files that calls
makefile.vc. Will help run Tcl in the debugger easier without
confusing MsDev for where the .pdb files are.
2001-11-07 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in:
* win/Makefile.in:
Print a message indicating that the user should
run "make genstubs" when the generated tclStubInit.c
file is out of date. We can't regenerate automatically
since there may be no tclsh on the system and that
would cause bootstrap problems. [Tcl bug 465874]
2001-11-07 Mo DeJong <mdejong@users.sourceforge.net>
Define TCL_INCLUDE_SPEC in tclConfig.sh. It should be
included by extensions that need to find Tcl include
headers in the install location. The user can override
the include install dir with --includedir so we need
to record this information for extensions. [Tcl bug 421835]
* unix/configure: Regen.
* unix/configure.in: Define TCL_INCLUDE_SPEC.
* unix/tclConfig.sh.in: Define TCL_INCLUDE_SPEC.
* win/configure: Regen.
* win/configure.in: Define TCL_INCLUDE_SPEC.
* win/tclConfig.sh.in: Define TCL_INCLUDE_SPEC.
2001-11-07 David Gravereaux <davygrvy@pobox.com>
* win/rules.vc:
* win/makefile.vc: Dropped the NOMSVCRT macro and put it on the
option list instead. It makes more sense to me this way as
NOMSVCRT=0 would only be the valid setting. Fixed the dde and reg
extension for building static. Improved, but not perfected, the
winhelp target.
2001-11-07 Mo DeJong <mdejong@users.sourceforge.net>
* win/README: Change minimum VC++ version to 5.X since
4.X is known not to work.
Indicate that Mingw is required and building with Cygwin
gcc is not supported. Include instructions that indicate
how to install Mingw and what URLs folks should use to
download the supported version of Mingw.
* win/configure: Regen.
* win/configure.in: Error out if user tries to compile the
Windows version of Tcl with Cygwin gcc. Users should compile
with Mingw gcc instead.
2001-11-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclIO.c (ReadChars): Fixed bug #478856 reported by
Stuart Cassoff <stwo@users.sourceforge.net>. The bug caused loss
of fileevents when [read]ing less data from the channel than
buffered. Due to an empty input buffer the flag
CHANNEL_NEED_MORE_DATA was set but never reset, causing the I/O
system to wait for more data instead of using a timer to
synthesize fileevents and to flush the pending data out of the
buffers.
2001-11-06 David Gravereaux <davygrvy@pobox.com>
* win/rules.vc (new):
* win/makefile.vc: Complete over/under rewrite to support numerous
build options all from the commandline itself without needing to
edit the makefile. Now requires vcvars32.bat to be run prior to
running nmake for bootstraping the environment. Fully doc'd usage
for it is in makefile.vc. Commentary welcome. Sticky points left
are:
1) winhelp target shows errors in the converting script.
2) .rc scripts aren't getting the right #defines to build the correct
"OriginalFilename" strings. (have patch, won't commit yet)
3) Naming convention with suffixes describing the buildtype are 'tsdx'
which will need public acceptance. ie. tclsh84tsx.exe is a (t)
threaded shell (s) statically linked to the core and (x) uses
msvcrt instead of libcmt.
2001-11-04 Vince Darley <vincentdarley@users.sourceforge.net>
* library/init.tcl: made filesystem fallback proc
::tcl::CopyDirectory more robust to vagaries of non-native
filesystems.
2001-11-02 Vince Darley <vincentdarley@users.sourceforge.net>
* doc/file.n:
* generic/tclIOUtil.c: updated documentation and comments
to clarify behaviour of 'file copy' wrt soft links.
2001-10-29 Vince Darley <vincentdarley@users.sourceforge.net>
* win/tclWinFile.c: fix to '-types {f r}' bug in
TclpMatchInDirectory (which could cause a UMR, as well as
returning wrong results). Also improved API for 'stat'
to resolve [Bug#219258].
* win/tclWin32Dll.c
* win/tclWinInt.h: addition of improved stat API to internal
lookup table.
* tests/fileName.test: two new tests for the above bug.
* generic/tclIOUtil.c: some cleanup of comments and #ifdefs
2001-10-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* unix/tclUnixFile.c (TclpMatchInDirectory): Argument to access()
was entryPtr->d_name instead of nativeEntry which failed when
trying to check access for files in other than the current
directory. [Bug 475941, reported by Georgios Petasis]
2001-10-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* unix/tclUnixChan.c: Added stateUpdated member to struct TtyState.
(TtyCloseProc,TtySetOptionProc,TtyInit): Use stateUpdated member
of TtyState to decide whether it is necessary to reset a serial
port when Tcl closes it. Blindly resetting can cause Tcl to be
sent an unexpected SIGTSTP when it is executing in the background
[Bug 471374, reported by Chris Nelson]
2001-10-22 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* doc/ObjectType.3: Minor documentation fix, reported by David
N. Welton <davidw@users.sourceforge.net> directly to me.
2001-10-22 Vince Darley <vincentdarley@users.sourceforge.net>
* win/tclWinFCmd.c: fix to stop test suite from hanging process
under some versions of WinNT. [Bug #466102] (Kevin Kenny)
2001-10-18 Jeff Hobbs <jeffh@ActiveState.com>
* tests/clock.test (clock-8.1):
* generic/tclDate.c (RelativeMonth):
* generic/tclGetDate.y (RelativeMonth): corrected off-by-one-day
error in clock scan with relative months and years during swing
hours. [Bug #413397, Patch #414024] (lavana)
2001-10-18 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c: fix to bug in Tcl_FSChdir shown up
by recent tclkit builds.
2001-10-17 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixPipe.c (PipeInputProc, PipeOutputProc): do immediate
retry when error is returned with errno == EINTR.
[Bug #415131] (leger)
2001-10-16 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclLoadAout.c (TclGuessPackageName): removed unused vars
and fixed warnings. [Bug #446622] (lim)
2001-10-15 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclProc.c: changing a memcmp to strncmp to avoid a memory
error detected by purify (thanks Jeff); modify style to agrre with
the style guide.
2001-10-15 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclInt.decls (TclExpandCodeArray,TclGetInstructionTable):
Added to internal stubs table. Tclcompiler (Tclpro project)
needs them if used as loadable package under Windows. Changed
signatures. We don't want to describe compiler internal
structures in "tclInt.h".
* generic/tclCompile.h: S.a. Removed function declarations.
* generic/tclCompile.c: S.a. Adapted to changed signatures.
2001-10-15 Jeff Hobbs <jeffh@ActiveState.com>
* unix/configure:
* unix/configure.in:
* win/configure:
* win/configure.in:
* win/tcl.m4: reworked to be a little cleaner in comparison to
each other, and to AC_SUBST even empty vars for win/tclConfig.sh
* generic/tclFileName.c: minor code cleanup
* generic/tcl.h: moved #define of WIN32 to tcl.h where __WIN32__
is defined and added #ifndef check.
* doc/open.n: moved all fconfigure option docs to fconfigure.n
* doc/fconfigure.n: added serial config options
* win/tclWinChan.c:
* win/tclWinPort.h:
* win/tclWinSerial.c: added TIP #35 Windows enhancements for
serial configuration. [Patch #438509] (schroedter)
2001-10-15 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclFCmd.c: fix to memory leak in TclFileDeleteCmd on
certain error conditions.
* doc/FileSystem.3: fix to typo.
2001-10-12 Jeff Hobbs <jeffh@ActiveState.com>
* library/encoding/ebcdic.enc:
* tools/encoding/ebcdic.txt: EBCDIC charset mapping.
[Patch #219323] (nijtmans)
* library/encoding/tis-620.enc:
* tools/encoding/tis-620.txt: TIS-620 charset mapping.
[Patch #467423] (poonlap)
* tests/http.test: added removeFile for outdata
* tests/ioCmd.test: added catch around file removal, as Windows
file locking throws errors.
* tests/socket.test (socket-7.2): corrected to work on Win2K.
2001-10-12 Miguel Sofer <msofer@users.sourceforge.net>
* tests/compile.test: new tests for [Bug 467523]; they are only
effective if TCL_MEM_DEBUG was set during compilation.
2001-10-11 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclLiteral.c (TclReleaseLiteral): insured that
self-referential bytecodes are properly cleaned up on interpreter
deletion [Bug 467523] (Ronnie Brunner)
2001-10-10 David Gravereaux <davygrvy@pobox.com>
* win/tclWinPort.h: #include <winsock2.h> needed to get moved
to after #include <windows.h> or wierd misunderstandings took
place when -D_WIN32_WINNT=0x0400 is set for outside code that
requires knowledge of Tcl innards. General header macro magic
applied liberally...
2001-10-10 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test: Corrected restore of ::env(LANG).
2001-10-09 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclFileName.c (Tcl_SplitPath): corrected mem leak
intro'd with VFS code where the result obj from Tcl_FSSplitPath
was not getting freed.
2001-10-09 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclLiteral.c: (TclReleaseLiteral) reverted previous
patch for [Bug 467523] - cure is worse than the illness.
2001-10-05 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclLiteral.c: (TclReleaseLiteral) insured that
self-referential bytecodes are properly cleaned up on interpreter
deletion [Bug 467523] (Ronnie Brunner)
2001-10-04 Jeff Hobbs <jeffh@ActiveState.com>
* tools/configure:
* tools/configure.in: noted 8.4 as default Tcl version
* library/encoding/cp936.enc:
* library/encoding/cp949.enc:
* library/encoding/cp950.enc:
* library/encoding/iso8859-16.enc:
* library/encoding/macCroatian.enc:
* library/encoding/macCyrillic.enc:
* library/encoding/macGreek.enc:
* library/encoding/macIceland.enc:
* library/encoding/macRoman.enc:
* library/encoding/macTurkish.enc:
* tools/encoding/cp1250.txt:
* tools/encoding/cp1251.txt:
* tools/encoding/cp1252.txt:
* tools/encoding/cp1253.txt:
* tools/encoding/cp1254.txt:
* tools/encoding/cp1255.txt:
* tools/encoding/cp1256.txt:
* tools/encoding/cp1257.txt:
* tools/encoding/cp1258.txt:
* tools/encoding/cp874.txt:
* tools/encoding/cp932.txt:
* tools/encoding/cp936.txt:
* tools/encoding/cp949.txt:
* tools/encoding/cp950.txt:
* tools/encoding/iso8859-1.txt:
* tools/encoding/iso8859-10.txt:
* tools/encoding/iso8859-13.txt:
* tools/encoding/iso8859-14.txt:
* tools/encoding/iso8859-15.txt:
* tools/encoding/iso8859-16.txt:
* tools/encoding/iso8859-2.txt:
* tools/encoding/iso8859-3.txt:
* tools/encoding/iso8859-4.txt:
* tools/encoding/iso8859-5.txt:
* tools/encoding/iso8859-6.txt:
* tools/encoding/iso8859-7.txt:
* tools/encoding/iso8859-8.txt:
* tools/encoding/iso8859-9.txt:
* tools/encoding/koi8-r.txt:
* tools/encoding/macCentEuro.txt:
* tools/encoding/macCroatian.txt:
* tools/encoding/macCyrillic.txt:
* tools/encoding/macGreek.txt:
* tools/encoding/macIceland.txt:
* tools/encoding/macRoman.txt:
* tools/encoding/macTurkish.txt:
Updated encodings with latest mappings from www.unicode.org. This
did not include some Mac encodings that have special multi-unichar
translations now (like symbols, dingbats and japanese). Also does
not include big5, gb or euc* as those have different formats in
the latest Unicode version that need new conversion tools. Not
all related .enc files changed as some had been updates separately.
2001-10-03 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclEvent.c (Tcl_FinalizeThread): moved freeing of
tclLibraryPath to before the thread exit handlers are called.
Slight modification to change on 2001-09-24.
2001-10-01 Jeff Hobbs <jeffh@ActiveState.com>
* win/configure: regen'ed
* win/tcl.m4:
* win/makefile.vc: added Win64 SDK RC1 compilation support
* win/Makefile.in: added $(LDFLAGS_CONSOLE) to TCLSH, TCLTEST and
PIPE_DLL_FILE targets to get the link flags
* win/tclWinInit.c: minor 64bit casts
2001-10-01 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCmdIL.c:
* generic/tclCmdMZ.c:
* generic/tclParseExpr.c: removed unnecessary inclusion of
tclCompile.h and made a small modification in (InfoBodyCmd) to
improve the isolation of the compiler/engine subsystem.
2001-09-29 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclIOUtil.c:
* doc/FileSystem.3: corrected and clarified documentation
for 'Tcl_FSListVolumes(Proc)'. No code changes.
2001-09-28 Miguel Sofer <msofer@users.sourceforge.net>
* doc/FindExec.3: added a comment not to change the working
directory before calling Tcl_GetNameOfExecutable [Bug 219215]
2001-09-28 Kevin Kenny <kennykb@users.sourceforge.net>
* generic/tclIO.c: added two more '(ClientData)' casts
on calls to Tcl_Preserve and Tcl_Release -- ones that
Vince apparently missed.
2001-09-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/lsort.n: Improved doc...
* generic/tclCmdIL.c (Tcl_LsortObjCmd, SortCompare): Made
offset-from-end indexing work, and factored out some "magic
numbers" for easier understanding. [Bug #465674]
* tests/cmdIL.test (cmdIL-1.26): Added test for offset-from-end
indexing for lsort.
2001-09-28 Vince Darley <vincentdarley@users.sourceforge.net>
* win/tclWinFCmd.c:
* unix/tclUnixFCmd.c: fix to performance issue reported
by jcw in which 'access("")' is called unnecessarily when
normalizing any absolute path.
* generic/tclIO.c: added '(ClientData)' cast to calls to
Tcl_(Preserve|Release) newly introduced, fixing compile
error on Windows.
2001-09-27 Don Porter <dgp@users.sourceforge.net>
* doc/FileSystem.3 (Tcl_FSLoadFile):
* generic/tcl.decls (Tcl_FSLoadFile):
* generic/tcl.h (Tcl_FSLoadFileProc):
* generic/tclInt.h (TclpLoadFile):
* generic/tclIOUtil.c (Tcl_FSLoadFile):
* generic/tclLoadNone.c (TclpLoadFile):
* generic/tclTest.c (TestReportLoadFile):
* library/ldAout.tcl:
* mac/tclMacLoad.c (TclpLoadFile):
* unix/tclLoadAix.c (TclpLoadFile):
* unix/tclLoadAout.c (TclpLoadFile):
* unix/tclLoadDl.c (TclpLoadFile):
* unix/tclLoadDld.c (TclpLoadFile):
* unix/tclLoadDyld.c (TclpLoadFile):
* unix/tclLoadNext.c (TclpLoadFile):
* unix/tclLoadOSF.c (TclpLoadFile):
* unix/tclLoadShl.c (TclpLoadFile):
* win/tclWinLoad.c (TclpLoadFile):
* win/tclWinFCmd.c (DoRemoveJustDirectory): More CONST poisoning
fixes from the 2001-09-24 TIP 27 changes. CONST-ified
Tcl_FSLoadFile and TclpLoadFile. Report and patch from Kevin
Kenny. [Bug 465833]
* generic/tclIO.c (ChannelTimerProc): Added Tcl_Preserve()
and Tcl_Release() to fix segfault introduced by the 2001-09-26
changes. [Bug 465494]
* doc/TCL_MEM_DEBUG.3: Updated out-of-date reference to
#define GUARD_SIZE.
* doc/UpVar.3 (Tcl_UpVar,Tcl_UpVar2):
* generic/tcl.decls (Tcl_UpVar,Tcl_UpVar2):
* generic/tclInt.decls (TclFindProc,TclGetFrame):
* generic/tclInt.h (TclFindProc,TclGetFrame,TclLookupVar,
TclPrecTraceProc,TclProcInterpProc}):
* generic/tclProc.c (TclGetFrame,TclFindProc):
* generic/tclVar.c (Tcl_UpVar,Tcl_UpVar2,MakeUpvar): Updated APIs in
generic/tclProc.c and generic/tclVar.c according to the guidelines
of TIP 27. [Patch 465442]
* generic/tclDecls.h:
* generic/tclIntDecls.h: make genstubs
2001-09-26 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* doc/fileevent.n: Accepted [Patch #465279] adding an example to
the fileevent manpage. Minor modifications to get a better
formatting. Report and patch by David N. Welton
<davidw@users.sourceforge.net>.
* The changes below fix [Bug #462317] where Expect tried to read
more than was in the buffers and then blocked in the OS call as
its pty channel driver provides no blockmodeproc through which
the OS could be notified of blocking-behaviour. Because of this
the general I/O core has to take more care than usual to
preserve the semantics of non-blocking channels.
The problem was reported by "Kevin O'Gorman"
<kevin@kosmanor.com>.
* generic/tclIO.c (Tcl_ReadRaw): Do not read from the driver if
the channel is non-blocking and the fileevent causing the read
was generated by a timer. We do not know if there is data
available from the OS. Instead of going to the OS for more and
potentially blocking we simply signal EWOULDBLOCK to the higher
levels to cause the system to wait for true fileevents.
(GetInput): Same as before.
(ChannelTimerProc): Added set and clear of CHANNEL_TIMER_FEV.
* generic/tclIO.h (CHANNEL_TIMER_FEV): New flag for channels. Is
set if a fileevent was generated by a timer, the channel is not
blocking and the driver did not provide a blockmodeproc. In that
case the I/O core has to be especially careful about going to
the driver for more data.
2001-09-26 Don Porter <dgp@users.sourceforge.net>
* doc/SplitPath.3 (Tcl_GetPathType):
* generic/tcl.decls (Tcl_GetPathType):
* generic/tclFileName.c (Tcl_GetPathType):
* win/tclWinFile.c (TclpMatchInDirectory, NativeStat): Vince
Darley reports the 2001-09-24 TIP 27 changes left the win
directory CONST poisoned. These changes should fix that.
* generic/tclDecls.h: make genstubs
2001-09-25 Don Porter <dgp@users.sourceforge.net>
* doc/GetInt.3:
* generic/tclInt.h (TclGetLong deleted):
* generic/tcl.decls:
* generic/tclInt.decls:
* generic/tclGet.c: Updated APIs in generic/tclGet.c
according to the guidelines of TIP 27. [Patch 464674]
* generic/tclDecls.h:
* generic/tclIntDecls.h: make genstubs
2001-09-25 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c: removed comments referring to unused flag
TCL_PARSE_PART1.
2001-09-24 Don Porter <dgp@users.sourceforge.net>
* doc/Concat.3:
* doc/DString.3:
* doc/SplitList.3:
* generic/tclInt.h (TclCheckBadOctal):
* generic/tcl.decls:
* generic/tclInt.decls:
* generic/tclEncoding.c (OpenEncodingFile):
* generic/tclMain.c (Tcl_Main):
* generic/tclUtil.c:
* unix/tclLoadDl.c (TclpLoadFile): Updated APIs in
generic/tclUtil.c according to the guidelines of TIP 27.
[Patch 464553]
* generic/tclDecls.h:
* generic/tclIntDecls.h: make genstubs
2001-09-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* The change below fixes [Bug #464380]. The bug was reported by
Ronnie Brunner <rbrunner@users.sourceforge.net>. He also
provided the patch.
* generic/tclEvent.c (Tcl_Finalize): Moved release of
'tclLibraryPath' to Tcl_FinalizeThread.
(Tcl_FinalizeThread): See above, new place for release of
'tclLibraryPath'.
2001-09-24 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tools/encoding/cp1252.txt: File was missing part of the encoding
[euro, ZCaron and zcaron].
* doc/OpenFileChnl.3: Add docs for Tcl_OutputBuffered; remove some
old changebars.
2001-09-21 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclExecute.c (TclExecuteByteCode): corrected
INST_STR_CMP else case for strings to pass true utf char length
to Tcl_UtfNCmp.
2001-09-20 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinInit.c: added extra processor definitions. (mstacy)
* win/tclWinSock.c (SocketThread): corrected pointer cast for _WIN64.
* win/tclWinNotify.c: removed unnecessary winsock include (it is
already in from tclWinPort.h).
* win/tclWinPort.h: changed winsock.h include to winsock2.h.
Reverses change from 2000-11-16, but is necessary for WIN64.
Extensions should comply with defined OS words, or use #ifndef.
2001-09-20 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/socket.test: removed dependence on being run from same dir
as remote.tcl, which only now needs to be in the same dir as
this file. [Bug #219326]
2001-09-19 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclTest.c (TestcmdtokenCmd): corrected pointer
storage/retrieval for 64bit machines.
* generic/tclCmdAH.c (Tcl_FormatObjCmd):
* generic/tclScan.c (Tcl_ScanObjCmd): corrected handling of format
and scan on 64-bit machines. [Bug #412696] (rmax)
* unix/configure: regen'ed
* unix/tcl.m4: added --enable-64bit support for HP-11 with the
64-bit kernel.
* tests/basic.test:
* tests/cmdInfo.test: improved skip reporting of missing commands
* tests/winFCmd.test: simplified error check for winFCmd-7.9
* tests/winPipe.test: removed obsolete cat16 tests
* generic/tclExecute.c (TclExecuteByteCode): fixed invalid usage
of valuePtr in TRACE_WITH_OBJ in INST_EVAL_STK case. [Bug #462594]
Changed INST_STR_CMP instruction to promote to Unicode strings
only when one of the strings is already of Unicode type.
* generic/tclExecute.c (TclExecuteByteCode):
* generic/tclCompile.c (instructionTable):
* generic/tclCompCmds.c (TclCompileStringCmd): INST_STR_MATCH -
Updated to Int1 instruction type and added special case to use
INST_STR_EQ instead when no glob chars are specified in a static
string.
* tests/{for.test,foreach.test,if.test,while.test}:
* generic/tclCompCmds.c (TclCompileForCmd, TclCompileForeachCmd,
TclCompileIfCmd, TclCompileWhileCmd): Corrected the overaggressive
compiling of loop bodies enclosed in ""s. [Bug #219166] (msofer)
2001-09-19 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: insured that execution stack errors are
also detected at abnormal returns.
2001-09-19 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/socket.n: Added documentation to mention what happens when a
server socket is created with port=0. Removed an old change bar,
and no new change bar because Tcl has always behaved this way as
it is really a poorly-documented standards-defined OS feature.
* tests/util.test (util-8.1): Test derived from code to detect the
problem, but the test always works in the C locale, so beware if
you are maintaining the code.
* generic/tclUtil.c (TclNeedSpace): Rewrote to be UTF-8 aware.
[Bug 411825, but not that patch which would have added extra
spaces if there was a real non-ASCII space involved. ]
2001-09-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclIOCmd.c (Tcl_PutsObjCmd): Rewritten to have saner and
faster argument handling. Fixes bug #123552. Patch provided by
Donal K. Fellows <fellowsd@cs.man.ac.uk>: #402564.
2001-09-18 Don Porter <dgp@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4 (SC_CONFIG_CFLAGS): On Linux, disable inlining when
one of the compat/*.c routines is to be linked in. [Patch 440891]
2001-09-17 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tcl.h: removed forced #define USE_TCLALLOC 1 for
Windows. This means the native system allocator will be used by
default. This should be binary and source compatible with
extensions, as Tcl_Alloc is a properly stubbed function.
2001-09-17 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: corrected small bug in [Patch 456668] -
the varFramePtr was not restored in one possible exit.
2001-09-17 Miguel Sofer <msofer@users.sourceforge.net>
* doc/tclvars.n:
* generic/tclCompile.c:
* generic/tclCompile.h:
* generic/tclExecute.c:
* generic/tclProc.c: disabled all compile and execution tracing
functionality in standard builds; TCL_COMPILE_DEBUG is now
necessary to enable it. [Bug 451858]
2001-09-14 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* doc/gets.n:
* doc/read.n:
* doc/puts.n:
* doc/flush.n:
* doc/fconfigure.n:
* doc/flush.n:
* doc/eof.n:
* doc/seek.n:
* doc/tell.n:
* doc/close.n:
* doc/fileevent.n: Added references to the Tcl standard
channels. Item [219250], reported by David LeBlanc
<whisper@oz.net>. Thanks to Christopher Nelson
<chris@pinebush.com> for doing editorial work.
2001-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* win/Makefile.in:
* win/configure.in:
* win/makefile.bc:
* win/makefile.vc:
* library/dde/pkgIndex.tcl: Fixed version numbers from bogus tcl
versions to independent versions for dde and registry packages.
2001-09-13 Jeff Hobbs <jeffh@ActiveState.com>
* tests/regexp.test (regexp-20.1):
* generic/tclCmdMZ.c (Tcl_RegsubObjCmd): had to adjust fix from
2001-08-06 to actually duplicate the objects in certain cases.
This is really a place where feather would have been essential.
[Bug #461322]
* generic/tclUtf.c (Tcl_UtfPrev): corrected to return the proper
location when the middle of a UTF-8 byte was passed in.
[Tk Bug #450504]
* ChangeLog.1999:
* ChangeLog: broke changes from 199x into ChangeLog.1999 to reduce
size of the main ChangeLog.
2001-09-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* tests/ioCmd.test: Changed the computation of the result for
iocmd-8.1[123] so that the tests work for single- and
multi-process execution of the testsuite. Depending on the
choice of the user stdout is a tty or not and thus reports
different channel options. Fixes [460993] reported by Don
Porter.
2001-09-13 Miguel Sofer <msofer@users.sourceforge.net>
* doc/ParseCmd.3:
* generic/tcl.decls:
* generic/tclCmdMZ.c (Tcl_SubstObjCmd):
* generic/tclDecls.h:
* generic/tclParse.c:
* generic/tclStubInit.c:
* tests/parse.test: Deprecate the use of Tcl_EvalTokens, replaced
by the new Tcl_EvalTokensStandard. The new function performs the
same duties but adheres to the standard return convention for Tcl
evaluations; the deprecated function could only return TCL_OK or
TCL_ERROR, which caused [Bug 219384] and [Bug 455151].
This patch implements [TIP 56].
2001-09-12 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4: Invert the logic that checks for $GCC.
Instead of checking for "$GCC" = "no" we check for
"$GCC" != "yes" or simply swap the true and false
blocks of code in an if statement. That way if
GCC is set to "" everything will still work. [Bug 460991]
2001-09-12 Don Porter <msofer@users.sourceforge.net>
* tests/appendComp.test:
* tests/lsearch.test:
* tests/namespace.test:
* tests/rename.test:
* tests/split.test: Corrected tests to better isolate tests in
one file from influencing tests in other files. [Bug 460591]
2001-09-12 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tcl.decls: reserved stub #481 for the implementation of
[TIP 56]
2001-09-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* doc/OpenFileChnl.3: Added documentation for Tcl_WriteRaw and
Tcl_ReadRaw [#414929].
* doc/CrtChannel.3: Added documentation for Tcl_ChannelBuffered
and Tcl_GetTopChannel [#414929].
* The changes below are a fix for [219253].
* tests/socket.test: Removed _most_ instances of hardwired port
numbers for listening sockets. Remaining are the ports in all
tests with constraint 'doTestsWithRemoteServer'. These seem to
be designed for a more controlled environment and are usually
skipped when running the testsuite.
* tests/io.test: Removed all instances of hardwired port numbers
for listening sockets.
2001-09-10 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclEvent.c (TclInExit): Corrected handling of tsd in
late stages of finalization. [Bug #419449] (darley)
* tests/stack.test:
* generic/tclInterp.c (AliasObjCmd): Check the numLevels to ensure
that we aren't hitting some alias loop condition. [Bug #443184]
2001-09-10 Mo DeJong <mdejong@users.sourceforge.net>
* unix/configure: Regen.
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Don't include . characters
in the Tcl library name when building on FreeBSD 3.X and later
systems. [Patch 450725]
2001-09-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* doc/tclsh.1:
* doc/Tcl_Main.3:
* doc/CrtChannel.3:
* doc/OpenFileChnl.3:
* doc/GetStdChan.3: Enhanced the manpages with cross-references to
the new manpage and more explanations how these functions deal
with the standard channels in various situations.
* doc/StdChannels.3: New manpage describing handling of the
standard channels by the Tcl library [402725].
2001-09-10 Don Porter <dgp@users.sourceforge.net>
* unix/mkLinks (Tcl_FSLink): Updated to reflect 2001-08-23
file system changes.
* unix/tclLoadShl.c: Added #include of tclInt.h; access to Tcl
internals, notably TclpUnloadFile(), is required. Thanks to
Bob Techentin for report and patch. [Bug 459305]
* generic/tclInitScript.h (initScript):
* win/tclWinInit.c (TCL_REGISTRY_KEY, TclpSetVariables): Removed
vestiges of Tcl's old initialization from registry variables.
[Bug 455645]
2001-09-10 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclInt.decls: Also added 'TclWinFlushDirtyChannels' to
the internal platform specific stub table.
* win/tclWinFile.c (TclpObjStat): Now added the call to
'TclWinFlushDirtyChannels' to this function. I don't know where
my head was last thursday (2001-09-06), but the call was
actually added to 'TclpObjChdir', i.e. the implementation of
[cd]. Corrected this now. Thanks to Vince Darley for spotting
this.
2001-09-10 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclProc.c:
* tests/proc.test: made [proc] bytecompile a no-op for procs
defined with _args_ as single argument and an empty body.
[FQ 451441]
2001-09-09 Mo DeJong <mdejong@users.sourceforge.net>
* unix/Makefile.in:
* win/Makefile.in: Use () around variable name
instead of {}. Use TCLTEST variable directly
instead of depending on the tcltest alias.
2001-09-09 David Gravereaux <davygrvy@pobox.com>
* generic/tcl.h:
* generic/tclPlatDecls.h: Reminder from David Cuthbert <dacut@kanga.org>
that I hadn't finished the Borland compatibility stuff.
[Patch: 436116]
2001-09-09 Mo DeJong <mdejong@users.sourceforge.net>
* tests/cmdAH.test: Modify cmdAH-20.5 and cmdAH-24.8
to display the file atime or mtime results if
the test fails.
2001-09-08 David Gravereaux <davygrvy@pobox.com>
* win/mkd.bat:
* win/rmd.bat: made these text files, text files again.
[Patch: 451333]
2001-09-08 Mo DeJong <mdejong@users.sourceforge.net>
* win/mkd.bat:
* win/rmd.bat:
Apply binary property (cvs admin -kb) to files and convert
to CRLF linefeed format to fix the VC++ build. [Bug #219409]
2001-09-08 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclInt.h:
* generic/tclFCmd.c:
* doc/FileSystem.3:
* generic/tclIOUtil.c: removed Tcl_FSCopyFile fallback
to channel copying, since the channels will not have
access to interpreters and the channel copying currently
requires an interp. Code which required cross-platform
copies always has interpreters, so that solves the problem.
Fixes bug in TclKit.
2001-09-07 David Gravereaux <davygrvy@pobox.com>
* win/tcl.m4: Added -link50compat option so a VC6 linker makes
a VC5 (pre sp3) compatible import library.
[Bug: 219257]
2001-09-07 Mo DeJong <mdejong@users.sourceforge.net>
* win/tclWinThrd.c (TclpThreadExit): Cast status argument to
_endthreadex to unsigned instead of DWORD to match the Win32
function prototype.
2001-09-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* All the changes below serve to fix bug [219148] which reports a
80x performance hit for file I/O on Win* systems. On my system
it was closer to a 120x hit. Problem report by Uwe Traum <no
email address available>.
The fix goes like this: The obstacle is 'FlushFileBuffers',
executed whenever Tcl writes data to the OS, as Tcl has to wait
for the disk to complete I/O, and disks are slow. We remove that
obstacle. This opens another problem, [file size] reports back
wrong numbers. So for [file size] we add the call back in. As
optimization we keep track of the channels which were written to
and flush only these.
* win/tclWinFile.c (TclpObjStat): Added a call to
'TclWinFlushDirtyChannels'. This ensures that [file size] and
related commands report the correct size of a file even if Tcl
has recently written to it. Unixoid OS's always report the
correct size even for files with pending data, but Win*
syssystem don't. They only report what is actually on disk.
* win/tclWinInt.h: Added declaration of
'TclWinFlushDirtyChannels', making it available to other parts
of the tcl core.
* win/tclWinChan.c (TclWinFlushDirtyChannels): New, internal,
procedure. Goes through the list of open file channels and
forces the OS to flush its file buffers for all which were
written to since the last call of this function. This is an
expensive operation as Tcl has to wait for the OS to complete
actual writes to the disk.
(FileInfo): Added dirty flag required by the procedure above.
(FileOutputProc): Removed flushing of file buffers, setting the
dirty flag instead. This means that the previously incurred
delays do not happen anymore.
(TclWinOpenFileChannel): Added initialization of 'dirty' flag.
2001-09-06 Jeff Hobbs <jeffh@ActiveState.com>
* doc/http.n: noted -binary, charset and coding state keys.
* tests/http.test:
* library/http/pkgIndex.tcl:
* library/http/http.tcl (geturl): correctly get charset parameter
and convert text according to specified encoding (if known). RFC
iso8859-1 is used by default. Also recognize Content-encoding to
see if we should do binary translation. Added a CYA -binary
switch for the cases that were missed. [Bug #219211 #219399]
* tests/ioUtil.test: changed to make better use of constraints and
remove knownBug constraints that weren't valid.
2001-09-06 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test (unixInit-3.2): Updated test to support
newer HP-UX releases that properly report euc-jp as the system
encoding for Japanese. Bug report and patch verification by Bob
Techentin. [Bug 453883]
* doc/http.n:
* library/http/*.tcl:
* tools/tcl.wse.in:
* tools/tclmin.wse:
* unix/Makefile.in:
* win/{Mm}akefile.*: Updated http package to version 2.4,
reflecting the new features just added.
2001-09-06 Vince Darley <vincentdarley@users.sourceforge.net>
* generic/tclTest.c: tests of old-fs hooks no longer cause problems
in threaded builds. Also removed unused unload proc.
* generic/tcl.decls:
* generic/tclIOUtilc: added Tcl_FSMountsChanged so that a vfs
can inform the filesystem that the filesystem epoch must be
changed (since cached filesystems may now be incorrect). Fixes
problem running tclvfs extension.
* library/tcltest/tcltest.tcl: if tests aren't in a native
filesystem, then don't use pipes to run them. [Bug 458741]
2001-09-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tcl.decls (479 generic):
* generic/tclIO.c (Tcl_Seek,Tcl_Tell,Tcl_OutputBuffered): Added
public function to return the size of the output buffer and
reworked other channel functions to use this shared functionality
and that of Tcl_InputBuffered() too. [TIP#49, Rolf Schroedter]
2001-09-05 David Gravereaux <davygrvy@pobox.com>
* generic/tclPlatDecls.h: Another small trim finalizing Borland
support.
* win/tclWinPipe.c:
* win/tclWinPort.h: More Borland compatibility fixes. Changed
EDQUOT #define from 49 to 69. Borland had a clash as it was already
using this number. Upon advice from Helmut Giese, EDQUOT has been
found in other header files #defined as 69.
[Patch: 436116]
* win/.cvsignore: A few more glob patterns added.
* win/makefile.bc (new): Borland lives once more! rejoice..
* generic/tclAlloc.c: Small Borland compatibility fix.
* win/tclWinTime.c: More Borland compatibility fixes.
[Patch: 436116]
2001-09-05 Vince Darley <vincentdarley@users.sourceforge.net>
* tests/winFCmd.test: made notWin2000 constraint false if not
running on Windows at all.
2001-09-04 David Gravereaux <davygrvy@pobox.com>
* win/tclWinThrd.c: Revisited _beginthreadex() stuff. Instead
of assuming a c-runtime implimentation of _beginthreadex normal,
I reversed the logic to not assume, and use when is by explicitly
needing to add runtimes that support it such as Borland.
* generic/tcl.h:
* generic/tclPlatDecls.h: Borland compatibility change so
ClientData was properly typed as a void* and TCHAR would not be
defined twice.
* generic/tcl.h: Removed a small mistake from before. Changes to
the EXTERN macro for proper Borland compatibility will have to see
a TIP. What's this with the MS compiler:
__declspec(dllexport) int func (int a, int b);
will have to be this with Borland:
int __cdecl __export func (int a, int b);
The order of the attribute needs to be after the return type.
2001-09-04 Don Porter <dgp@users.sourceforge.net>
* compat/strtod.c (strtod): Fixed failure to handle expressions
like 3eq2 and failure to set errno on overflow. [Bug 440894]
2001-09-04 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclProc.c:
* tests/proc.test: made [proc] check that formal args have
simple names [Bug 458548]
2001-09-04 Vince Darley <vincentdarley@users.sourceforge.net>
Minor bug fixes in filesystem, plus small vfs changes as a
result of enabling the test filesystem to work properly.
* tests/fileName.test: ensure new test cleans up after itself
* doc/filename.n:
* generic/tclFileName.c: improved Mac path handling and document
why [Bug: 421842] on Windows handling of UNC paths is not valid.
Documentation and code now much clearer on what is and is not a
UNC path.
* doc/FileSystem.3:
* unix/tclUnixPipe.c:
* generic/tclFCmd.c:
* generic/tclIOUtil.c: fixed error message, fixed [Bug: 453512]
about dangerous use of tmpnam, replaced with mkstemp.
Documented all the changes.
* generic/tclTest.c: made test vfs fully functional as a
'reporting filesystem'.
* generic/tcl.stubs:
* generic/tcl.h:
* generic/tclInt.h:
* generic/tclIOUtil.c:
* doc/file.n:
* various platform-specific 'TclpLoadFile': fixed comments about
unload behaviour, and completed objectification of loading.
Required change to Tcl_Filesystem lookup table, so incompatible
with 8.4a3, but not older versions of Tcl. The change also
allows 'link' and 'reporting' filesystems to function correctly
when loading files. Implementation of 'file delete -force'
copes with case where cwd is inside the directory. Moved
overlooked Tcl_FSGetPathType from internal to external API.
Made sure filesystems which are registered and then unregistered
are only freed when all references to them are gone.
Documented changes.
* unix/tclUnixFCmd.c: when deleting directories recursively,
make sure permissions are ok. Together with the above, this
fixes [Bug: 219139]
* tests/winFCmd.test: differentiated test results for win2k
versus not. This fixes [Bug: 219239]
* tests/fCmd.test: added tests for 'file delete -force' where
the cwd is inside, and when permissions are inadequate.
2001-09-04 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompile.c: fixed incorrect operands for INST_LIST
[Bug: 458241] (David Cuthbert, dacut@users.sourceforge.net)
2001-09-03 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclExecute.c (TclExecuteByteCode): fixed missing comma
in debug macro.
2001-09-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/ExprLongObj.3: Fixed error in documentation of argument type
to Tcl_ExprObj [Bug: 457435]
2001-09-02 David Gravereaux <davygrvy@pobox.com>
* win/tclWinThrd.c: Portability fix for Cygwin who's c-runtime,
not surprisingly, doesn't have the MSVCRT specific _beginthreadex /
_endthreadex pair. This might have to be revisited for proper
Borland, lcc32, Watcom and other support as well.
[Patch: 444255]
* win/tclWinThrd.c: Moved FinalizeConditionEvent() proto to within
the main #ifdef TCL_THREADS block to avoid mingw warning about it
being there but unused.
* win/makefile.vc: Added -Zl (zee el) to tclStubLib.c compile line
to make sure the tclstub84.lib static library is built without
requiring a specific C-runtime library at link-time for the end-use
developer. It has been noted on c.l.t that this trips many first
time users trying to make extensions.
[Patch: 403533]
2001-08-31 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclInt.h: added TclCompileListCmd header
* generic/tclBasic.c: added TclCompileListCmd compile proc
* generic/tclCompCmds.c (TclCompileListCmd): function to compile
the 'list' command at parse time.
* generic/tclExecute.c (TclExecuteByteCode): definition of
INST_LIST bytecode.
* doc/StringObj.3: added words of warning to use Tcl_ResetResult
with the Tcl_Append* functions.
* tests/compile.test: added compile-11.* interp result checks
* generic/tclUtil.c (TclGetIntForIndex): added Tcl_ResetResult
before Tcl_AppendStringsToObj to prevent shared object crash when
called from bcc instruction. The Tcl_Append* calls that append to
the result object that are invoked by bcc insts must remember to
call Tcl_ResetResult because the bcc doesn't do this for us.
[Bug #456892]
2001-08-30 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIndexObj.c: fixed some casting problems that upset
Crays. [Bug #419528] (andreasen)
2001-08-30 Don Porter <dgp@users.sourceforge.net>
* generic/tcl.h: Silence warning from Sun compiler. [Bug 454374]
2001-08-30 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: allow cached fully-qualified command names
to be usable from different namespaces within the same interpreter
without forcing a new lookup. This speeds up scripts that pass
command names in variables ("this" in some OO packages).
[Patch 456668].
2001-08-30 Vince Darley <vincentdarley@users.sourceforge.net>
Further fs updates. After examining the most common Tcl
extensions (TclX, BLT, Tk, TclPro, Mktclapp), it has been
determined that only TclpGetCwd and the Access/Stat/Open
insert/delete hooks of the internal fs functions are ever used.
The remaining functions from Tcl's internal interfaces have
therefore been removed, since Tcl now exports a more suitable
public API (Tcl_FS...)
* generic/tclInt.stubs:
* generic/tclInt.h: updated for removed internal functions.
Some new internal functions have been put in tclInt.h (and
not exported in the stub table because good public equivalents
exist).
* generic/tclTest.c: some test functions used the internal private
APIs. These tests have been retained, but modified to use
public APIs. Also objectified the internal filesystem tests.
* win/tclWinFile.c: removed TclpStat, TclpAccess and refactored
code to use NativeAccess, NativeStat. This should speed up
stat, access and glob commands.
* win/tclWinFCmd.c: removed all TclpCopy/Rename/Delete
File/Directory string-based procedures which aren't used any more.
Improved efficiency of some other procedures. Ensure that filename
conversions with a NULL interp do not crash Tcl.
* mac/tclMacFCmd.c: wrapped long lines and cleaned up
TclpObjNormalizePath, removed all TclpCopy/Rename/Delete
File/Directory string-based procedures which aren't used any more.
* mac/tclMacFile.c: removed obsolete TclpStat, TclpAccess, TclpChdir,
etc.
* unix/tclUnixFCmd.c: removed use of TclpAccess, removed all
TclpCopy/Rename/Delete File/Directory string-based procedures which
aren't used any more.
* unix/tclUnixFile.c: removed obsolete TclpStat, TclpAccess, TclpChdir,
etc.
* tcl(Unix|Mac|Win)Chan.c: objectified TclpOpenFileChannel.
* various 'load' implementations all objectified.
* generic/tclFileName.c: removed redundant code.
* generic/tclIOUtil.c: removed TclStat, TclAccess, TclpListVolumes.
Fix to MatchInDirectory at the root of a volume. Also improved
some documentation, and improved default path joining behaviour
for virtual filesystems, especially regarding '~'.
* tests/fileName.test: added tests to check for bugs fixed above.
* doc/FileName.3: improved documentation
2001-08-30 David Gravereaux <davygrvy@pobox.com>
* generic/tclAsync.c:
* generic/tclEvent.c:
* generic/tclInt.h: Improper cleanup of asyncMutex in tclAsync.c
repaired. TclFinalizeSynchronization() was trying to remove a
registered mutex that was dumped earlier when the TSD it was stored
in was cleared. This was only surfacing on *nix. Windows was being
masked by mutexes not actually being returned to the system! That
was repaired in a previous patch. Needed to add a private
TclFinalizeAsync() to tclAsync.c and called from Tcl_FinalizeThread().
Pheww.. Is this done yet?
[Bug: 414419] requested by Rob Ratcliff <rrr6399@futuretek.com>
2001-08-28 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclCompCmds.c (TclPushVarName): noted 'static' defn.
[Bug #453872]
2001-08-26 Don Porter <dgp@users.sourceforge.net>
* library/auto.tcl (tcl_findLibrary):
* tests/unixInit.test (unixInit-2.{1,9}):
* unix/tclUnixInit.c (TclpInitLibraryPath):
* win/tclWinInit.c (TclpInitLibraryPath): Corrected
inconsistency between the search path for script libraries and
the directory name $DISTNAME into which distributions built
by 'make test' unpack. [Bug 455642]
2001-08-24 Jeff Hobbs <jeffh@ActiveState.com>
* tests/stringComp.test: added string-1.3
* generic/tclCompCmds.c (TclCompileStringCmd): changed to return
TCL_OUT_LINE_COMPILE instead of TCL_ERROR when compiling and an
unknown string method is called. This is necessary as the string
command may be never called, or not until 'string' is redefined.
2001-08-24 Vince Darley <vincentdarley@users.sourceforge.net>
* doc/glob.n: documented windows-style path issue with glob.
[Bug: 219392]
* doc/filename.n: documented windows path/file length limitation.
[Bug: 454597]
2001-08-24 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test (unixInit-2.9): Corrected expected result
to match Tcl's quirky construction of its init library path.
2001-08-23 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* win/tclWinPipe.c (BuildCommandLine): Fixed tcl Bug
[432499]. Part of the code used the non-absolute path to the
executable to determine quoting. This failed if the absolute
path contained spaces, but the application name itself not. This
bug caused no trouble on Win NT 5, but does for other variants
in the Win* family. Report and fix due to Ken Poole
<kenpoole@users.sourceforge.net>.
2001-08-23 Jeff Hobbs <jeffh@ActiveState.com>
* unix/configure:
* unix/tcl.m4: added QNX-6 build support. [Bug #219410] (loverso)
* unix/tclUnixFCmd.c:
* generic/tclIOUtil.c:
* generic/tclFileName.c: corrected minor compiler warnings.
2001-08-23 Vince Darley <vincentdarley@users.sourceforge.net>
Variety of small filesystem and vfs issues fixed or improved.
The new fs code allows many new opportunities for efficiency
improvements through the objectified API. The main changes
integrated here are such efficiency improvements. Some
limitations of the original implementation have also now been
lifted. Meanwhile a variety of fs bugs (some old, some new)
have also been fixed.
* generic/tclFileName.c: Made Tcl_FSSplitPath more efficient,
and removed some static string-based procedures which are no
longer used. Much more objectification. Tcl_FSJoinPath
is now very efficient and more aware of virtual filesystems.
Clarified where the Mac-specific code attempts to interpret
Unix-style paths. Modified TclDoGlob to use lstat not
access to fix [Bug: 434876, L. Virden]
* tcl(Win|Unix|Mac)FCmd.c:
* tcl(Win|Unix|Mac)File.c: replaced TclpListVolumes with
TclpObjListVolumes with different signature, updated code due
to more efficient signature of Tcl_FSGetTranslatedPath. Used
cached native paths where possible to improve efficiency --
this was completed on MacOS, but on Unix and Win the traversal
functions make the task much more complex, so there are still
some improvements possible there. Removed unused
TclpNormalizePath which had been left in tclWinFCmd.c.
Objectified all 'file attributes' functions. Fixed the new
[Bug:451571, Bruce Stephens] which is most obvious on Unix,
but could occur on MacOS or Windows. This bug actually existed
in Tcl 8.3.x but was only made obvious by the recent filesystem
overhaul when the code was exercised more heavily.
* tests/fileName.test: Three new tests to exercise the above bug,
and make sure it is fixed correctly.
* unix/tclUnixFile.c: avoid panic in glob when a link
doesn't point anywhere. It would probably be good to define
exactly what Tcl should do in circumstances like these, and
make sure mac/win/unix all behave accordingly. [Bug: 417111,
Hemang Lavana]. Also fixed misleading/obsolete comment in the code.
* generic/tcl.stubs: changed signature of Tcl_FSGetTranslatedPath
and added Tcl_FSGetTranslatedStringPath.
These changes allow further optimisations in the FS code.
* generic/tcl.h: changed signature of Tcl_FSListVolumes so that
it doesn't require a Tcl interpreter plus result. Renamed
Tcl_FSReadLink to Tcl_FSLink with additional argument so
we can support making links in the future. [Patch: 450340]
* generic/tclInt.h:
added declaration for TclpObjListVolumes. Objectified
internal call signatures for 'file attributes' functions, and
added an internal objectified get path type function.
* generic/tclIOUtil.c: added the moved function TclpListVolumes
which calls platform specific code (needed for backwards
compatibility), and improved efficiency of parts of the FS
(particularly file normalization). Much less copying and
memory allocation is required now. added new GetPathType
so that changes in 'file volumes' can actually affect files'
types, and objectified more code. Made current code work
with test suite artificially changing current platform.
Added 'static' keywords where required.
* generic/tclIO.c:
* generic/tclTest.c: Added 'static' keywords, fixing
[Bug: 453872, Bob Techentin]
* generic/tclCmdAH.c: file command implementation updated for
API changes, removed unnecessary special-case SplitPath static
function, since it no longer helps prevent code duplication.
Moved setting of interpreter result to each individual location
that actually required it, to avoid very large code separation
between reading and setting the result.
* doc/FileSystem.3: updated documentation for the new or
changed APIs, and clarified some issues.
* doc/SplitPath.3: added pointer to newer APIs in FileSystem.3
* doc/filename.n: clarified current implementation of tilde
support on Mac/Win. [Bug:453514, Sergey Kuzmin]
* doc/glob.n: improved documentation for '-directory' and '-path'
options.
There are now many private, obsolete, platform-specific 'Tclp'
string-based filesystem APIs which could be removed. We should
check whether any of these are used by extensions and, at least
in Tcl 9, remove them.
The above changes signify a ***POTENTIAL INCOMPATIBILITY***
with 8.4a3, since signatures of two functions in the new API
have changed, but not with older versions of Tcl.
2001-08-23 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclBinary.c (FormatNumber): Extract a long from the
object and not an int, to stop [binary format] from being unable
to format some input numbers on architectures where sizeof(int) is
less than sizeof(long) (particularly Alpha.) [tiprender Bug #441861]
* tests/format.test: Converted conditional execution of tests into
a test constraint.
2001-08-22 Jeff Hobbs <jeffh@ActiveState.com>
* win/Makefile.in:
* win/makefile.vc: updated install target for dde1.2
* doc/dde.n: fixed dde man page (which was totally incorrect).
* tests/winDde.test:
* win/tclWinDde.c (Tcl_DdeObjCmd): added -binary option to dde
request command to allow for returning binary data. [Bug #227482]
Updated dde to 1.2
* tests/tcltest.test: added unixExecs constraint to files that
used 'grep' in the test. [Bug #453143]
* library/tcltest/tcltest.tcl: fixed stdio constraint test.
[Patch #454050] (stanton)
Simplified unixExecs constraint test.
2001-08-22 Don Porter <dgp@users.sourceforge.net>
* tests/ioUtil.test (ioUtil-3.*): Corrected errors in tests
revealed by fix of overagressive compiler. [Bug 451200]
2001-08-21 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclCompCmds.c:
* tests/compile.test: Fixed overagressive compilation of [catch]:
it was catching errors at substitution time. [Bug #219184]
2001-08-21 Jeff Hobbs <jeffh@ActiveState.com>
* tests/tcltest.test (tcltest-12.2): fixed test that would break
when env vars weren't Tcl list friendly [Patch #454046] (stanton)
2001-08-20 Jeff Hobbs <jeffh@ActiveState.com>
* library/http/http.tcl (geturl): added port number to Host:
header to comply with HTTP/1.1 spec (RFC 2068). [Bug #452217]
2001-08-16 David Gravereaux <davygrvy@pobox.com>
* tools/tcl.wse.in:
* tools/tcl.hpj.in:
* win/tcl.hpj.in: Removed -kb storage in CVS to ensure these text
files are checked-out in the translation mode CVS is in. Setting
these as binary as part of an effort to make sure they are always
in CRLF, no matter what the CVS translation, is bypassing how CVS
works and is confusing.
* tools/genStubs.tcl: Removed LF-only output. Having to reconvert
back to CRLF before committing to CVS was giving me a headache.
[Bug: 451333]
* win/makefile.vc: replaced $(WINDIR) with $(include32) for the
.rc.res inference rule. winver.h wasn't getting included.
[Bug: 445630]
2001-08-14 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclBasic.c: make the intial maxNestingDepth of an
interpreter be MAX_NESTING_DEPTH instead of a hardwired value
[Bug: 232564]
2001-08-13 Miguel Sofer <msofer@users.sourceforge.net>
* tests/trace.test: Corrected test numbers [Bug: 449794]
2001-08-12 Mo DeJong <mdejong@redhat.com>
* unix/configure: Regen.
* unix/configure.in:
* unix/tcl.m4: Use GCC variable set by AC_PROG_CC instead
of defining our own using_gcc variable.
2001-08-11 Vince Darley <vincentdarley@users.sourceforge.net>
Variety of small issues introduced by the vfs code fixed:
* generic/tclIOUtil.c: uninitialised read.
* generic/tclFCmd.c: possible memory leak in file delete
with error condition.
2001-08-10 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclVar.c:
* tests/trace.test: Insure that [array] traces work correctly for
undefined variables [Bug: 449094]
2001-08-09 Mo DeJong <mdejong@redhat.com>
* unix/Makefile.in: Delete the unused getcwd.o
target. This fixes bug #440942.
2001-08-08 Don Porter <dgp@users.sourceforge.net>
* library/dde/pkgIndex.tcl:
* library/http/http.tcl:
* library/http/pkgIndex.tcl:
* library/msgcat/msgcat.tcl:
* library/msgcat/pkgIndex.tcl:
* library/opt/optparse.tcl:
* library/opt/pkgIndex.tcl:
* library/reg/pkgIndex.tcl:
* library/tcltest/tcltest.tcl:
* library/tcltest/pkgIndex.tcl: Added checks for package dependencies.
Bumped patchlevels of changed packages: http 2.3.2, msgcat 1.2.2,
opt 0.4.3, tcltest 2.0.1. [Patch 448931]
* README:
* generic/tcl.h:
* tools/tcl.wse.in:
* unix/configure:
* unix/configure.in:
* unix/tcl.spec:
* win/README.binary:
* win/configure:
* win/configure.in: Bumped up patchlevel to 8.4a4 to distinguish
CVS snapshots from the 8.4a3 release. This does not necessarily
mean there will be an 8.4a4 release. [Bug 448938].
2001-08-06 Jeff Hobbs <jeffh@ActiveState.com>
8.4a3 RELEASE
* changes:
* README:
* mac/README:
* unix/README:
* win/README.binary: updated for 8.4a3 release
* generic/tclFileName.c (Tcl_FSSplitPath): update to Tcl style
guide.
* generic/tclFCmd.c (FileCopyRename): fixed mem leak in
introduction of vfs code where a new Tcl_Obj wasn't freed.
* generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd):
reordered the retrieval of arguments to avoid shimmering bug when
the pattern and string referenced the same object.
* unix/configure: regenerated
* unix/tcl.m4: added GNU (HURD) configuration target. (brinkmann)
[Patch: #442974]
* win/README: made note of URL for Windows compilation notes
* win/tclWinThrd.c (TclpFinalizeMutex, TclpFinalizeCondition):
added DeleteCriticalSection calls for cleanup [Patch: #419683]
* unix/tclUnixPipe.c (TclpCreateTempFile): fixed use of tmpnam,
which is dangerous. [Patch: #442636] (lim)
The use of tmpnam in TclpTempFileName must still be changed.
* tests/http.test (http-4.14): fixed variable error return.
[Bug: 424252]
2001-08-03 Jeff Hobbs <jeffh@ActiveState.com>
* win/configure: regenerated
* win/tcl.m4: fixed DLLSUFFIX definition to always be ${DBGX}.dll.
This is necessary for TEA compliant builds that build shared
against a static-built Tcl.
* win/Makefile.in ($(TCLSH)): added $(TCL_STUB_LIB_FILE) to build
target, otherwise it wouldn't get generated in a static build.
2001-08-06 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclIOCmd.c (Tcl_GetsObjCmd): Applied patch from SF item
[442665] to fix the bug reported by it. The function can corrupt
a freed object if it is called with objc == 3. This is because
it retrieves resultPtr and does not increment its reference
count, but then calls Tcl_ObjSetVar2, which causes the retrieved
resultPtr object to be released.
2001-08-06 Don Porter <dgp@users.sourceforge.net>
* doc/tclsh.1: Added note that the tclsh program is frequently
installed with the Tcl version numer as part of the name.
[Patch 402725]
* generic/tclPkg.c:
* tests/pkg.test: [package forget] now forgets all of the
package arguments it receives, not stopping when a package is
not found. [Bug 415273]
2001-08-02 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclIOUtil.c (Tcl_FSMatchInDirectory): corrected
uninitialized value.
2001-08-02 Mo DeJong <mdejong@redhat.com>
* generic/tclPlatDecls.h:
* win/tclWinPort.h:
Revert <tchar.h> related changes made to improve
Cygwin support on 2001-07-18. This change ended
up breaking the VC++ build because of conflicts
between Windows APIs and internal Tk APIs.
2001-08-01 Jeff Hobbs <jeffh@ActiveState.com>
* unix/tclUnixFCmd.c: minor casts to eliminate warnings. (lim)
[Patch: #440218]
* tests/parseOld.test: changed some tests that required
testwordend to exist to skip in a proper tcltest manner.
[Bug: #442663]
* library/http/http.tcl (http::mapReply): the regsub'ing of \n and
\t to escape them was unnecessary.
2001-07-31 Vince Darley <vincentdarley@users.sourceforge.net>
Changes from TIP#17 "Redo Tcl's filesystem"
The following files were impacted:
* doc/Access.3:
* doc/FileSystem.3:
* doc/OpenFileChnl.3:
* doc/file.n:
* doc/glob.n:
* generic/tcl.decls:
* generic/tcl.h:
* generic/tclCmdAH.c:
* generic/tclCmdIL.c:
* generic/tclCmdMZ.c:
* generic/tclDate.c:
* generic/tclDecls.h:
* generic/tclEncoding.c:
* generic/tclFCmd.c:
* generic/tclFileName.c:
* generic/tclGetDate.y:
* generic/tclIO.c:
* generic/tclIOCmd.c:
* generic/tclIOUtil.c:
* generic/tclInt.decls:
* generic/tclInt.h:
* generic/tclIntDecls.h:
* generic/tclLoad.c:
* generic/tclStubInit.c:
* generic/tclTest.c:
* generic/tclUtil.c:
* library/init.tcl:
* mac/tclMacFCmd.c:
* mac/tclMacFile.c:
* mac/tclMacInit.c:
* mac/tclMacPort.h:
* mac/tclMacResource.c:
* mac/tclMacTime.c:
* tests/cmdAH.test:
* tests/event.test:
* tests/fCmd.test:
* tests/fileName.test:
* tests/io.test:
* tests/ioCmd.test:
* tests/proc-old.test:
* tests/registry.test:
* tests/unixFCmd.test:
* tests/winDde.test:
* tests/winFCmd.test:
* unix/mkLinks:
* unix/tclUnixFCmd.c:
* unix/tclUnixFile.c:
* unix/tclUnixInit.c:
* unix/tclUnixPipe.c:
* win/tclWinFCmd.c:
* win/tclWinFile.c:
* win/tclWinInit.c:
* win/tclWinPipe.c
2001-07-24 Mo DeJong <mdejong@redhat.com>
* win/tclWinThrd.c (Tcl_CreateThread): Close Windows
HANDLE returned by _beginthreadex. The MS documentation
states that this handle is not closed by a later call to
_endthreadex.
2001-07-21 Don Porter <dgp@users.sourceforge.net>
* doc/pkgMkindex.n:
* library/package.tcl: Corrected documentation and usage
message of [pkg_mkIndex].
2001-07-18 Mo DeJong <mdejong@redhat.com>
* generic/tclPlatDecls.h: Define TCHAR by including
windows.h instead of tchar.h since Cygwin does not
support the tchar.h header. Include CHECK_UNICODE_CALLS
logic from tclWinPort.h.
* win/tclWinPort.h: Remove CHECK_UNICODE_CALLS logic.
Remove include of windows.h since this now done it
tclPlatDecls.h.
* win/tclWinReg.c: Remove duplicate include of windows.h.
2001-07-18 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclIO.c: Aftermath to [SF #427196]. Squash empty buffers
if they are smaller than the requested buffersize, to prevent
reusage of old buffers and to honor changes in the requested
buffersize made by the user.
2001-07-17 Mo DeJong <mdejong@redhat.com>
* win/tclWinFile.c (TclpReadlink): Add Cygwin specific definition
for the TclpReadlink function. This method implements reading of
symbolic links when build with Cygwin.
2001-07-17 Mo DeJong <mdejong@redhat.com>
* win/tclWinPort.h: Add Cygwin specific defines for environ
and timezone variables.
2001-07-17 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclIO.c (GetInput): Fixed [SF #427196]. Memory was
overwritten because a buffer was used after a change of the
requested buffersize together with that requested buffersize and
not its actual size, which was smaller. Note that the continous
reuse of the smaller buffer negatively impacts performance. The
system never allocates a buffer with the newly requested bigger
buffersize.
2001-07-16 Mo DeJong <mdejong@redhat.com>
* generic/tcl.h: Define __WIN32__ when
__CYGWIN__ or __MINGW32__ is defined.
* generic/tclAlloc.c: Define caddr_t when
compiling with VC++ or mingw. This type is
already defined when compiling with Cygwin.
2001-07-16 Mo DeJong <mdejong@redhat.com>
* win/tclWinConsole.c:
* win/tclWinPipe.c:
* win/tclWinPort.h:
* win/tclWinSerial.c:
* win/tclWinThrd.c:
Remove unnecessary #includes of dos.h, direct.h,
and tchar.h. This will help the Cygwin porting
effort since these headers do not exist under Cygwin.
2001-07-16 Jeff Hobbs <jeffh@ActiveState.com>
* win/tclWinPipe.c (PipeClose2Proc): constrained the mutex lock to
just the TerminateThread call and waiting for termination. (jsmith)
* generic/tclCmdMZ.c: Removed extra copy of the SCAN_* macros
#defined in generic/tclScan.c. (porter) [Bug 441230]
2001-07-12 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/unixInit.test (unixInit-2.8): Added extra constraint,
notInstalledInTmp, to stop this test from damaging installations
in /tmp; not much fun to have to reinstall the Tcl library every
time you run the test suite!
* tests/subst.test (subst-10.*): Updated tests to check new
behaviour for 'break' in command substitutions.
(subst-1.2,subst-7.1): Error messages changed.
* doc/SubstObj.3: New file, to document Tcl_SubstObj.
* doc/subst.n: Improved and updated documentation for 'subst' to
help support the changed behaviour.
* generic/tcl.decls (generic-437): Declaration for Tcl_SubstObj
* generic/tcl.h (TCL_SUBST_*): Added flags for Tcl_SubstObj.
* generic/tclCmdMZ.c (Tcl_SubstObj,Tcl_SubstObjCmd): Divided into
two parts to allow people to access the innards of 'subst' and
changed the behaviour when command substitutions do a 'break' to
be different from 'continue'. Also now works with objects, which
allows for some nifty optimisations with variable substitutions
and a slight improvement with command substitutions. [TIP#36]
2001-07-10 Mo DeJong <mdejong@redhat.com>
* unix/Makefile.in: Add AR variable for use in STLIB_LD.
* unix/configure: Regen.
* unix/configure.in: Use STLIB_LD when defining MAKE_LIB
and MAKE_STUB_LIB. Subst RANLIB and AR.
* unix/tcl.m4 (SC_CONFIG_CFLAGS): Add doc comment about
STLIB_LD command. Check ${AR} env var when setting
STLIB_LD and delay evaluation until make time.
* win/configure: Regen.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Delay evaluation of
${AR} in STLIB_LD and add flags to better match the
Unix implementation. Don't bother defining AR when
using VC++ since it is not used.
2001-07-06 Mo DeJong <mdejong@redhat.com>
* win/configure: Regen.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Pass -e _WinMain@16 in
addition to the -mwindows flag to work around a problem
with ld when it incorrectly use main() as the executable
entry point when both WinMain() and main() are available.
2001-07-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/cmdAH.test: Added leading zero to file modes to work
around fault in HPUX strtol() which ignores the base parameter
[Bug #438808]
2001-07-05 Mo DeJong <mdejong@redhat.com>
* win/Makefile.in: Subst DEPARG directly instead
of relying on a variable. This will make Cygwin
builds faster since an extra exec will be avoided.
* win/configure: Regen.
* win/configure.in: Subst DEPARG.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Move AC_MSG_CHECKING
after the AC_CHECK_PROG so that status messages do
not get mixed together. Set DEPARG based on the
results of the cygpath check so that we avoid using
an extra exec when it is not needed. Use ac_cv_cygwin
status flag instead of looking at the output of
gcc -v, which works in the case where -mno-cygwin is
set in the CFLAGS.
2001-07-04 Jeff Hobbs <jeffh@ActiveState.com>
* README:
* mac/README:
* unix/README:
* win/README:
* win/README.binary: updated READMEs with purls
2001-07-03 Mo DeJong <mdejong@redhat.com>
* win/Makefile.in: Remove PATHTYPE variable.
* win/configure: Regen.
* win/configure.in: Don't subst PATHTYPE.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Remove PATHTYPE
variable. Set CYGPATH to "cygpath -w" if the
cygpath executable is found on the path. This
approach works for native Cygwin builds and
cross compiles.
2001-07-03 Jeff Hobbs <jeffh@ActiveState.com>
* tests/var.test:
* generic/tclVar.c (Tcl_VariableObjCmd): added patch to check for
number of args. [Patch #426038]
* generic/tclVar.c (Tcl_GetVar2Ex): added ability to recognize
TCL_TRACE_READS flags to cause creation of part1 in TclLookupVar
to make sure newly created array will get read traces triggered
appropriately. This is called by Tcl_ObjGetVar2, Tcl_GetVar, and
Tcl_GetVar2.
(TclSetIndexedScalar, TclSetElementOfIndexedArray): added read
trace triggering for lappend case.
(Tcl_LappendObjCmd): pass TCL_TRACE_READS to Tcl_ObjGetVar2 to
trigger possible read traces for new arrays.
* generic/tclExecute.c (TclExecuteByteCode): added TCL_TRACE_READS
flag to INST_LAPPEND(_ARRAY)_STK case to trigger read traces for
newly created arrays. Removed unnecessary #ifdef for
TCL_COMPILE_DEBUG in INST_LOAD_SCALAR1 case.
* tests/append.test:
* tests/appendComp.test: added tests for read trace triggering for
append and lappend.
2001-07-03 Mo DeJong <mdejong@redhat.com>
* tests/clock.test (clock-2.5): Adjust test so that it passes
when the time slice is 60 msecs, now passes under Windows 98.
2001-07-03 Mo DeJong <mdejong@redhat.com>
* win/tcl.m4 (SC_CONFIG_CFLAGS): Don't pass the v flag
to ${AR} when using gcc, verbose output is not needed.
2001-07-03 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test (unixInit-2.8): Changed test back to using
installation layout, adding comments explaining why the test writes
to the directories it does, and checks to avoid destroying other
files in /tmp.
2001-07-03 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/unixInit.test (unixInit-1.2): Fixed faults reported in
Bug#438070 - well, at least enough to work on Solaris - and added
comments that should make what is going on in the test clearer.
2001-07-02 Jeff Hobbs <jeffh@ActiveState.com>
* tests/util.test: added util-4.6
* generic/tclUtil.c (Tcl_ConcatObj): Corrected walking backwards
over utf-8 chars. [Bug #227512]
2001-07-02 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test (unixInit-2.8): Corrected test for all
absolute pathnames in library path when executable is installed
near root directory to use correct development directory layout.
[Bug 438014]
* tests/unixInit.test (unixInit-2.9):
* unix/tclUnixInit.c (TclpInitLibraryPath):
* win/tclWinInit.c (TclpInitLibraryPath): Corrected buggy
construction of search path entries relative to executable.
Added test for bad construction. [Bug 438014]
2001-06-28 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclNamesp.c: Correction to faulty patch from [Bug: 231259]
2001-06-28 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/unixInit.test (unixInit-1.2): Modified so as not to
require a local echo service, which fails on many systems which
have that turned off for security reasons...
2001-06-27 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclInt.h:
* generic/tclObj.c:
* unix/Makefile.in: added a -DPURIFY mode that makes Tcl_Obj's
allocated and free singularly (instead of in alloc in blocks and
never free) to allow checkers like Purify to operate better.
* library/encoding/koi8-u.enc: added koi8-u (Ukranian variant)
encoding.
* tests/subst.test:
* generic/tclUtf.c (Tcl_UtfBackslash): Corrected backslash
handling of multibyte utf-8 chars. [Bug #217987]
* generic/tclCmdIL.c (InfoProcsCmd): fixed potential mem leak in
info procs that created objects without using them.
* generic/tclCompCmds.c (TclCompileStringCmd): fixed mem leak when
string command failed to parse the subcommand.
* doc/interp.n:
* doc/unknown.n: updated notes about what is in a safe interp.
[Bug #218605]
2001-06-27 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/event.test (event-11.5): Removed hard-coded port number
which could fail on some systems. [Bug #436727]
2001-06-26 Mo DeJong <mdejong@redhat.com>
* unix/Makefile.in:
* win/Makefile.in: Add `make shell` target. This target
will set the proper env vars before invoking tclsh
from the build directory.
2001-06-26 Mo DeJong <mdejong@redhat.com>
* win/Makefile.in: Use : to separate VPATH entries. This
works for both Cygwin builds and cross builds, the VPSEP
variable is simply unneeded complexity.
* win/configure: Regen.
* win/configure.in: Don't subst VPSEP.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Remove VPSEP variable.
2001-06-26 Mo DeJong <mdejong@redhat.com>
* unix/configure: Regen.
* unix/configure.in: Fix last checkin by removing
export since that only works in bash.
* win/configure: Regen.
* win/configure.in: Ditto.
2001-06-26 Mo DeJong <mdejong@redhat.com>
* unix/configure: Regen.
* unix/configure.in: Set CFLAGS to "" if the user
did not set CFLAGS in the env. This keeps AC_PROG_CC
from adding "-g -O2" to the CFLAGS by default.
* win/configure: Regen.
* win/configure.in: Ditto.
2001-06-25 Mo DeJong <mdejong@redhat.com>
* win/configure: Regen.
* win/configure.in: Use RC_DEFINE flag from tcl.m4.
* win/tcl.m4 (SC_CONFIG_CFLAGS): Set RC_DEFINE
flag based on the compiler in use.
2001-06-25 Mo DeJong <mdejong@redhat.com>
* win/tcl.m4 (SC_CONFIG_CFLAGS): Link to the
imm32 library when building with mingw gcc.
2001-06-25 Mo DeJong <mdejong@redhat.com>
* win/configure: Regen.
* win/tcl.m4 (SC_CONFIG_CFLAGS): When building with
gcc, don't attempt to link with LD or support dllwrap.
Simply require a recent version of Cygwin gcc or Mingw
gcc that supports -shared. When linking, use gcc instead
of ld since gcc automatically includes libs like -lmsvcrt.
2001-06-22 Mo DeJong <mdejong@redhat.com>
* win/configure: Regen.
* win/configure.in: Add resource compiler fix from
8.3.3 to fix compiling with mingw.
2001-06-22 Mo DeJong <mdejong@redhat.com>
* win/configure: Regen.
* win/tcl.m4: Fix silly typo in last checkin.
2001-06-22 Mo DeJong <mdejong@redhat.com>
* unix/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@.
Set LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@. Add LDFLAGS_DEBUG
and LDFLAGS_OPTIMIZE to match the way CFLAGS_DEFAULT works.
This will support user set CFLAGS or LDFLAGS at configure time.
* unix/configure: Regen.
* unix/configure.in: Don't set CFLAGS to CFLAGS_DEFAULT, instead
subst CFLAGS_DEFAULT into the Makefile. Add AC_SUBST for CFLAGS_DEFAULT,
LDFLAGS_DEFAULT, LDFLAGS_DEBUG, and LDFLAGS_OPTIMIZE.
* unix/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that
it uses a Makefile variable just like CFLAGS_DEFAULT.
* win/Makefile.in: Set CFLAGS to @CFLAGS@ and @CFLAGS_DEFAULT@.
Set LDFLAGS to @LDFLAGS@ and @LDFLAGS_DEFAULT@.
This will support user set CFLAGS or LDFLAGS at configure time.
* win/configure: Regen.
* win/configure.in: Don't set CFLAGS or LDFLAGS, instead subst
CFLAGS_DEFAULT and LDFLAGS_DEFAULT into the Makefile.
* win/tcl.m4 (SC_ENABLE_SYMBOLS): Modify LDFLAGS_DEFAULT so that
it uses a Makefile variable just like CFLAGS_DEFAULT.
2001-06-22 Mo DeJong <mdejong@redhat.com>
* win/configure:
* win/tcl.m4 (SC_CONFIG_CFLAGS): Don't set LDFLAGS_DEBUG
to -g or LDFLAGS_OPTIMIZE to -O when compiling with gcc.
These flags are not needed and can cause problems with
the Cygwin version of ld.
2001-06-18 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/unixInit.test (unixInit-1.2,unixInit-2.8): Added test for
code described below, and fixed a couple of errors that caused
problems during testing; the code to determine the installedTcl
constraint was wrong, and test unixInit-2.8 assumed that /tmp/lib
was free for use and could be deleted, which clashed nastily with
my installation and made other tests fail unnecessarily!
* unix/tclUnixChan.c (TtyInit,TclpOpenFileChannel,
Tcl_MakeFileChannel,TclpGetDefaultStdChannel): Alterations so that
the standard channels - stdin, stdout and stderr - have the
correct type and fconfigure options. This required making the
initialisation of serial lines a little more sophisticated to
make the console behave correctly in interactive mode... [Bug
#219137 and duplicates]
2001-06-16 Don Porter <dgp@users.sourceforge.net>
* generic/tclInt.decls:
* generic/tclInt.h:
* generic/tclPanic.c (Tcl_PanicVA):
* mac/tclMacAppInit.c (main):
* mac/tclMacPanic.c (TclpPanic):
* unix/tclUnixPort.h:
* win/tclWinPort.h: Replaced TclMacSetPanic with TclpPanic
for setting a platform-specific panic handler. TclpPanic
is NULL on Unix and Windows. Fixes broken wish on Mac due
to earlier patches. [Patch 415648]
* generic/tclIntPlatDecls.h:
* generic/tclStubInit.c: `make gentubs` after above changes.
2001-06-13 Don Porter <dgp@users.sourceforge.net>
* mac/tclMacAppInit.c (main, Macintosh_Init):
* mac/tclMacBOAAppInit.c (main):
* mac/tclMacPanic.c: Applied patches from Dan Steffen correcting
problems on the Macintosh in the 2001-06-08 changes.
2001-06-12 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/regexp.test (regexp-18.12):
* generic/tclCmdMZ.c (Tcl_RegexpObjCmd): Fixed so that submatches
that do not match always have index pair {-1 -1} [Bug #219232]
2001-06-08 Don Porter <dgp@users.sourceforge.net>
* generic/tcl.h:
* generic/tcl.decls:
* generic/tclPanic.c: Added CONST to Tcl_*Panic* public interfaces.
[Patch 415648, TIP 27]
* generic/tclInt.decls:
* mac/tclMacAppInit.c (main):
* mac/tclMacBOAAppInit.c (main):
* mac/tclMacPanic.c: Modified special Mac implementations of
Tcl_*Panic* to be exact copies of the generic implementations.
Added TclMacSetPanic. The generic implementations should be
used directly, rather than copies, but that requires further
changes by someone familiar with the Mac build systems.
[Patch 415648]
* generic/tclDecls.h:
* generic/tclIntPlatDecls.h:
* generic/tclStubInit.c: `make gentubs` after above changes.
* doc/Panic.3:
* unix/mkLinks: New file documenting Tcl_*Panic* public interfaces,
followed by `make mklinks`. [Patch 415648, Bug 219170, Bug 414936]
2001-06-03 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclUtil.c (Tcl_DStringAppendElement): patch to save an
extra strlen call. [Bug #428572]
2001-05-30 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclExecute.c (TclExecuteByteCode): Added two casts to
INST_STR_CMP implementation to get rid of a couple warnings from
the SUNWspro C compiler.
* generic/tclBasic.c (Tcl_GetMathFuncInfo,Tcl_ListMathFuncs):
* generic/tclCmdIL.c (Tcl_InfoObjCmd,InfoFunctionsCmd):
* generic/tcl.decls (generic table, positions 435+436):
* tests/info.test:
* doc/CrtMathFnc.3:
* doc/info.n: Changes due to TIP #15 "Functions to List and Detail
Math Functions"
2001-05-28 Jeff Hobbs <jeffh@ActiveState.com>
* library/init.tcl (unknown): removed errant " in error message
2001-05-27 Jeff Hobbs <jeffh@ActiveState.com>
* generic/regc_locale.c: updated character class range data for
Unicode v3.1.0 compliance.
* generic/tclUniData.c: regenerated from Unicode v3.1.0 data file
(new as of 2001-05-16). This brings Tcl to current unicode
compliance.
* tests/utf.test: added tests to check unicode 3 compliance
* unix/Makefile.in (tclUtf.o): added tclUniData.c dependency.
* tools/uniClass.tcl: added comments to output format and the
script for clarification.
* tools/uniParse.tcl: corrected filename output and GetDelta macro
to use 'info' as param (was 'infO')
2001-05-26 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclVar.c (tclArraySearchType,SetArraySearchObj,
ParseSearchId): Added code to speed up array searching by reducing
the amount of parsing needed for searchIds.
* generic/tclObj.c (TclInitObjSubsystem):
* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct):
* generic/tclNamesp.c (TclInitNamespaceSubsystem):
* generic/tclInt.h: Moved some Tcl_ObjType initialisation to
TclInitObjSubsystem to be with the bulk of the rest.
[Patch 424851] Committed by Miguel Sofer <mig@utdt.edu>
2001-05-23 Jeff Hobbs <jeffh@ActiveState.com>
* tests/io.test: changed io-52.[9-11] to not be platform sensitive
with EOL translation.
* library/encoding/cp1250.enc:
* library/encoding/cp1251.enc:
* library/encoding/cp1252.enc:
* library/encoding/cp1253.enc:
* library/encoding/cp1254.enc:
* library/encoding/cp1255.enc:
* library/encoding/cp1256.enc:
* library/encoding/cp1257.enc:
* library/encoding/cp1258.enc:
* library/encoding/cp874.enc:
* library/encoding/iso8859-6.enc:
* library/encoding/iso8859-7.enc:
* library/encoding/iso8859-8.enc:
* library/encoding/iso8859-10.enc (new):
* library/encoding/iso8859-13.enc (new):
* library/encoding/iso8859-14.enc (new): updated encoding tables
based on http://www.unicode.org/Public/MAPPINGS/. (kuhn)
2001-05-23 Mo DeJong <mdejong@redhat.com>
* unix/tcl.m4 (SC_PATH_TCLCONFIG): Fix comments,
and typo in cached variable name.
2001-05-23 Mo DeJong <mdejong@redhat.com>
* unix/tcl.m4 (SC_LOAD_TKCONFIG):
Remove use of undefined TCLCONFIG variable and
call AC_MSG_RESULT to print the checking result.
* win/tcl.m4: Ditto.
2001-05-22 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclObj.c (TclAllocateFreeObjects): simplified
objSizePlusPadding to use sizeof(Tcl_Obj) (max)
Corrected use of tclObjsAlloced/Freed/Shared in TCL_MEM_DEBUG
compile.
2001-05-22 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: removed Tcl_DuplicateObj in INST_DUP
2001-05-21 Jeff Hobbs <jeffh@ActiveState.com>
* tests/tcltest.test (tcltest-19.1): fixed failing test that was
getting affected by Windows env handling of empty valued elements.
* unix/tcl.m4: added more common install directories in which to
search for *Config.sh [Bug #419812]
* tests/cmdMZ.test (cmdMZ-1.4): added notLinux constraint to test
to prevent failure message on Linux due to OS caching bug.
* tests/httpd (httpdRespond): added response to timeout value in
query string.
* tests/http.test: removed unused notLinux constraint setting
* generic/tclRegexp.c (Tcl_RegExpExecObj): added use of
Tcl_GetUnicodeFromObj.
2001-05-19 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* Note that "tclbench" (see project "tcllib") was extended with
performance benchmarks for [fcopy] too.
* doc/fcopy.n: Updated to reflect the extended behaviour of 'fcopy'.
* tests/io.test: Added tests 'io-52.9', 'io-52.10' and 'io-52.11'
to test the handling of encodings by 'fcopy' / 'TclCopychannel'
[Bug #209210].
* generic/tclIO.c: Split of both 'Tcl_ReadChars' and
'Tcl_WriteChars' into a public error checking and an internal
working part. The public functions now use the new internal
ones. The new functions are 'DoReadChars' and 'DoWriteChars'.
Extended 'CopyData' to use the new functions 'DoXChars' when
required by the encodings on the input and output channels
[Bug #209210].
2001-05-16 Jeff Hobbs <jeffh@ActiveState.com>
* library/history.tcl (tcl::HistAdd): prevent empty calls from
being added to the history (arndt)
* tests/error.test: updated error-1.3 message to account for
string index being compiled at toplevel.
* tests/appendComp.test:
* tests/stringComp.test: new files for extended bytecode testing
* generic/tclBasic.c: added new CompileProc invocations to basic
command initialization.
* generic/tclCompCmds.c: added new compile commands for append,
lappend, lindex and llength. Refactored set and incr compile
commands to use new TclPushVarName function for handling the
varname component during compilation (also used by append and
lappend). Changed string compile command to compile toplevel code
as well (when possible).
* generic/tclCompile.c: added new instruction enums
* generic/tclCompile.h: added debug info for new instructions
* generic/tclExecute.c (TclExecuteByteCode): moved elemPtr to
toplevel var (oft-used). Added definitions for new bytecode
instructions INST_LIST_INDEX, INST_LIST_LENGTH, INST_APPEND_SCALAR1,
INST_APPEND_SCALAR4, INST_APPEND_ARRAY1, INST_APPEND_ARRAY4,
INST_APPEND_ARRAY_STK, INST_APPEND_STK, INST_LAPPEND_SCALAR1,
INST_LAPPEND_SCALAR4, INST_LAPPEND_ARRAY1, INST_LAPPEND_ARRAY4,
INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK.
Refactored repititious code for reuse with INST_LOAD_STK (same as
INST_LOAD_SCALAR_STK), INST_STORE_STK (same as
INST_STORE_SCALAR_STK).
Updated INST_STR_CMP with style of fix of 2001-04-06 Fellows
[Bug #219201] as that fix only affected the runtime eval'ed
"string" (string compare is normally byte-compiled now). We
may want to back these out for speed in the future, noting the
problems with \x00 comparisons in the docs.
* generic/tclInt.h: declarations for new compile commands.
* generic/tclVar.c: change TclGetIndexedScalar,
TclGetElementOfIndexedArray, TclSetElementOfIndexedArray and
TclSetIndexedScalar to use flags. The Set functions now support
TCL_APPEND_ELEMENT and TCL_LIST_ELEMENT as well.
* generic/tclInt.decls:
* generic/tclIntDecls.h: minor signature changes for above.
* generic/tclCmdMZ.c: made use of new Tcl_GetUnicodeFromObj.
2001-05-16 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/console.n: Deleted. Put it in the wrong source tree! D'oh!
2001-05-15 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tcl.decls:
* generic/tclDecls.h:
* generic/tclStubInit.c:
* generic/tclStringObj.c (Tcl_GetUnicodeFromObj): new function to
parallel Tcl_GetStringFromObj (fix of an API oversight).
* unix/tclUnixPipe.c: updated pipeChannelType to
TCL_CHANNEL_VERSION_2 type specification.
* tests/fileName.test: corrected tests not to fail on win when a
C:/test dir exists.
* generic/tclFileName.c (ExtractWinRoot): corrected ABR error
2001-05-15 Miguel Sofer <msofer@users.sourceforge.net>
* tests/lindex.test: added test for nested braces [Patch: 423617]
2001-05-15 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclInt.h
* generic/tclNamesp.c: invalidate all bytecodes in a namespace if
a new command shadows a bytecoded command.
* tests/namespace.test
Patched from [Bug: 231259]
2001-05-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/console.n: Created. It seems very odd to me that the
console implementation is part of the Tcl distribution and not
part of Tk, but given the location of the source, the
documentation must obviously match up...
2001-05-14 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdMZ.c (Tcl_StringObjCmd):
* tests/string.test (string-4.14): Negative string indices should
not be added as offsets to the result of [string first] but
instead be treated as referring to the start of the string.
[Bug: 423581]
2001-05-11 Mo DeJong <mdejong@redhat.com>
* unix/Makefile.in: Add a LDFLAGS variable to the
Makefile instead of directly substing @LDFLAGS@.
* unix/configure: Regen.
* unix/tcl.m4: Fix CFLAGS_DEFAULT so that the name
of a Makefile variable is passed as @CFLAGS@.
* win/Makefile.in: Move the setting of CFLAGS
higher up in the Makefile.
* win/configure: Regen.
* win/configure.in: Use dnl to comment out macros
so that they are not accidently expanded.
* win/tcl.m4: Fix CFLAGS_DEFAULT so that the name
of a Makefile variable is passed as @CFLAGS@.
2001-05-07 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: insure different rand() seeds in different
threads [Bug 416643]
2001-05-03 Jeff Hobbs <jeffh@ActiveState.com>
* tests/tcltest.test: removed extraneous 'c' (doh!) [Bug: 414031]
* tools/tcltk-man2html.tcl: removed use of 'exec' for portability
and fixed up code.
2001-05-03 Don Porter <dgp@users.sourceforge.net>
* doc/library.n:
* library/init.tcl:
* tests/autoMkindex.t*: Modified [auto_import] to apply
pattern matching in the [namespace import] style. [Bug 420186]
***POTENTIAL INCOMPATIBILITY*** for any callers of [auto_import]
from outside Tcl that expect the pattern matching to be like that
of [string match].
2001-05-03 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclParse.c:
* tests/namespace.test: Insure consistent behaviour of the
[unknown] command: when a command is unknown, it is always
processed by [::unknown], ignoring any namespace proc which
happens to be called "unknown" [Patch #421166, Bug #420507]
2001-05-02 Don Porter <dgp@users.sourceforge.net>
* tools/genStubs.tcl: Add a package require of Tcl 8
at the beginning of the script so that the script
will print a descriptive error message when run
in an old Tcl 7 shell.
2001-04-27 Kevin Kenny <kennykb@crd.ge.com>
* generic/tclInt.decls:
* generic/tclInt.h:
* generic/tclCmdIL.c:
* generic/tclProc.c:
* generic/tclVar.c: Added another collection of missing CONSTs
related to TclGetNamespaceForQualName.
* generic/tclIntDecls.h: Regenerated.
2001-04-25 Mo DeJong <mdejong@redhat.com>
* unix/configure: Regen.
* unix/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
* unix/tclConfig.sh.in: Add TCL_THREADS variable.
* win/configure: Regen.
* win/tcl.m4: Subst TCL_THREADS into tclConfig.sh.
* win/tclConfig.sh.in: Add TCL_THREADS variable.
2001-04-25 Mo DeJong <mdejong@redhat.com>
* unix/configure: Regen.
* unix/configure.in: Use $@ in MAKE_LIB and MAKE_STUB_LIB
commands instead of using a delayed subst variable. Replace
instances of STUB_LIB_FILE with TCL_STUB_LIB_FILE.
2001-04-25 Mo DeJong <mdejong@redhat.com>
* unix/Makefile.in: Use TCL_STUB_LIB_FILE instead of STUB_LIB_FILE.
* unix/configure: Regen.
* unix/configure.in: Don't subst STUB_LIB_FILE, use TCL_STUB_LIB_FILE
instead.
2001-04-25 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tools/encoding/iso8859-15.txt:
* library/encoding/iso8859-15.enc: Oops! Got the full encoding
wrong. Should be fixed now...
* tools/encoding/iso8859-15.txt:
* library/encoding/iso8859-15.enc:
* tools/tcl.wse.in: Added ISO 8859-15 (a.k.a. Latin-1 + Euro
currency symbol) support.
* generic/tclNamesp.c:
* generic/tclBasic.c (TclRenameCommand): Missing CONST from
several declarations relating to use of TclGetNamespaceForQualName
2001-04-24 Kevin B. Kenny <kennykb@acm.org>
* doc/AssocData.3:
* doc/CrtCommand.3:
* doc/CrtMathFnc.3:
* doc/CrtObjCmd.3:
* doc/ExprLong.3:
* generic/tclBasic.c:
* generic/tclCmdMZ.c:
* doc/CrtSlave.3:
* generic/tclNamesp.c:
* generic/tcl.decls:
* generic/tcl.h:
* generic/tclInt.decls:
* generic/tclInt.h: (TIP #27) Another round of CONST changes, this
time adding CONST to the API's exported from tclBasic.c.
[Patch #415179]
***POTENTIAL INCOMPATIBILITY*** from 8.4a2, in which Vince
Darley's changes to command tracing were added. A const has been
added to the type signature of one of the parameters to
Tcl_CommandTraceProc.
2001-04-10 Kevin B. Kenny <kennykb@acm.org>
* unix/tclUnixTime.c: Altered code to use memcpy instead of
structure assigments in an effort to achieve better K&R
compatibility.
2001-04-10 Kevin B. Kenny <kennykb@acm.org>
* unix/tclUnixTime.c: Fixed silly typo in calls to 'gmtime' and
'localtime' that broke the Linux build.
2001-04-09 Kevin B. Kenny <kennykb@acm.org>
* unix/tclLoadShl.c: Added DYNAMIC_PATH to the load flags so that
the SHLIB_PATH will be searched for other libraries. [Bug #219140]
2001-04-09 Kevin B. Kenny <kennykb@acm.org>
* unix/tcl.m4: Added _REENTRANT to Solaris build so that thread
safe library routines are included.
* unix/configure: Re-ran 'autoconf' with changed tcl.m4
* tclUnixTime.c: Modified for thread safety of 'gmtime' and
'localtime' system calls [Bugs #219136 and #232558]
2001-04-09 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/expr.test (expr-21.*): Tests to check below fix.
* generic/tclParseExpr.c (GetLexeme): Now recognises the
non-numeric boolean literals for what they are. It no longer makes
sense for anyone to create functions with the same name as one of
them, but this was true in 7.* as well [Bug #217777; finally!]
2001-04-07 Miguel Sofer <msofer@users.sourceforge.net>
* generic/tclExecute.c: Avoid panic when there are extra items in
the tcl stack [Bug #406709, Patch #414470]
* tests/foreach.test: test to exercise the patch
2001-04-07 Miguel Sofer <msofer@users.sourceforge.net>
* doc/namespace.n: document correct functionality
* generic/tclNamesp.c: corrected behaviour of [namespace code]
(Bug #219385, Patch #403530)
* library/init.tcl:
* tests/namespace-old.test: test correct functionality
* tests/namespace.test: test correct functionality
2001-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* unix/Makefile.in (checkdoc): New target, checking the
definitions as found in the compiled library against the
manpages to find undocumented public functionality.
* unix/mkLinks: Updated to include the new manpage.
* doc/UniCharIsAlpha.3: New manpage documenting the Unicode
character classification APIs [Bug #218720].
2001-04-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* unix/mkLinks: Updated to incorporate the changes below.
* doc/StringObj.3: Added 'Tcl_AttemptSetObjLength' to the NAME
section. [Bug #414435].
* doc/Alloc.3: Added both 'Tcl_AttemptAlloc' and
'Tcl_AttemptRealloc' to the NAME section. [Bug #414435].
* doc/Utf.3: Added both 'Tcl_UniCharCaseMatch' and
'Tcl_UniCharNcasecmp' to the NAME section. [Bug #414435].
2001-04-06 Don Porter <dgp@users.sourceforge.net>
* library/init.tcl:
* tests/init.test: Modified processing of $::errorInfo by
[unknown] when the auto-loaded command throws an error to better
cover the tracks of auto-loading. [Bug 219280, Patch 403551]
2001-04-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/read.n: Added section on "USE WITH SERIAL PORTS" to resolve
[Bug #219402]
* tests/string.test (string-2.30): Test for this case
* generic/tclCmdMZ.c (Tcl_StringObjCmd, STR_COMPARE branch): Fixed
problem caused by Utf-rep of \x00 being more than Utf-rep of \x01
fooling memcmp by forcing everything through Utf-based
comparisons. Added optimizations for case where objects have a
string/unicode-rep or a bytearray-rep (i.e. where we can perform
comparisons on fixed-size units.) [Bug #219201]
* generic/tclUtf.c (Tcl_UtfNcmp): Corrected seriously erroneous
comment.
2001-04-05 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* doc/Macintosh.3: Removed duplicates from .SH line
[Bug #413983].
2001-04-05 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdMZ.c (Tcl_StringObjCmd): Fixed so will compile
with K&R compilers [Patch #413844, Bug #413847]
2001-04-04 Don Porter <dgp@users.sourceforge.net>
* generic/tclMain.c: Patch from Kevin Kenny to restore support of
pre-ANSI compilers. [Bug 413846, Patch 413842]
2001-04-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* unix/mkLinks: Updated to contain the new manpage.
* doc/Environment.3: New manpage, describes Tcl_PutEnv
[Bug #219171].
* doc/Macintosh.3: New manpage describing the macintosh specific
parts of the public API [Bug #219169].
2001-04-04 Jeff Hobbs <jeffh@ActiveState.com>
* unix/configure:
* unix/tcl.m4: extended test of termios vs. termio vs. sgtty to
better detect result on Linux and when certain configure
redirections are being used. (max) [Patch #402923; Bug #227412,
#219194]
2001-04-04 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* generic/tclTest.c:
* tests/io.tests: TIP #10 followup correcting a problem with the
original patch because of the lack of 'testthread id' for a
non-threaded compilation.
2001-04-04 Kevin Kenny <kennykb@acm.org>
* doc/ByteArrObj.3:
* doc/DumpActiveMemory.3:
* doc/InitStubs.3:
* doc/PkgRequire.3:
* doc/StringObj.3:
* generic/tcl.decls:
* generic/tcl.h:
* generic/tclBinary.c:
* generic/tclCkalloc.c:
* generic/tclDecls.h:
* generic/tclListObj.c:
* generic/tclObj.c:
* generic/tclPkg.c:
* generic/tclStringObj.c:
* generic/tclStubLib.c:
(TIP#27) Changed a number of Tcl API's to accept "CONST char*"
in place of simple "char*". (kennykb) [Patch #404026]
2001-04-04 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclListObj.c (Tcl_SetListObj): set objPtr->length = 0 in
empty object case to maintain sanctity of Tcl_Obj bytes/length
pairing. (porter) [Patch #405998]
2001-04-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* unix/mkLinks: Added 'Signal.3', 'Tcl_WaitPid'.
* doc/DetachPids.3: Added description of 'Tcl_WaitPid' [Bug #219173].
* doc/Signal.3: New man page describing the public API procedures
'Tcl_SignalId' and 'Tcl_SignalMsg' [Bug #219172].
2001-04-02 Jeff Hobbs <jeffh@ActiveState.com>
* README:
* win/README:
* win/README.binary: further notes corrections.
* win/configure:
* win/tcl.m4 (SHLIB_LD): added -incremental:no. [Bug #219381]
2001-04-01 Jeff Hobbs <jeffh@ActiveState.com>
* README:
* mac/README:
* win/README:
* win/README.binary:
* unix/README: updated patchlevel information to 8.4a3 and
updated links and notes.
* generic/tcl.h:
* tools/tcl.wse.in:
* win/configure.in (VER):
* win/configure:
* unix/configure:
* unix/configure.in (VER):
* unix/tcl.spec: updated patchlevel information to 8.4a3
2001-03-30 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclCkalloc.c (TclFinalizeMemorySubsystem): set curTagPtr
to NULL to allow for reuse.
* generic/tclEvent.c (Tcl_Finalize): moved the tsdPtr
initialization inside the subsystemsInitialized check to prevent
it potentially getting called twice during finalization. (wu)
[Patch #403532, Bug #219391]
* generic/tclThreadTest.c (Tcl_ThreadObjCmd): cast fixes
* generic/tclTest.c (TestChannelCmd): added cast to mollify
Windows debug build.
* win/tclWinSock.c (SocketEventProc): Fixed race condition in
readability of socket on Windows.
[Patch #410674, Bug #219205 #219333]
* win/tcl.m4: added imm32.lib to LIBS_GUI for Tk IME support.
* win/Makefile.in (install-libraries): removed extra \s that broke
the target.
(install-doc): improved install-* targets to use their base build
dependency.
2001-03-30 Andreas Kupries <andreas_kupries@users.sourceforge.net>
* All of the changes below belong to TIP #10 [Tcl I/O Enhancement:
Thread-Aware Channels]. See also [Patch #403358] at SF.
* generic/tclIO.h (struct ChannelState, line 236f): Extended the
structure with a new field of type 'Tcl_ThreadId' to hold the id
of the thread currently managing all channels with this state.
Note: This structure is shared by all channels in a stack of
transformations.
* generic/tclIO.c (Tcl_CreateChannel, lines 1058-1065): Modified
to store the Id of the current thread in the 'ChannelState' of
the new channel.
* generic/tclIO.c (Tcl_SpliceChannel, lines 2265-2270): Modified
in the same manner as 'Tcl_CreateChannel' as the channel will be
managed by the current thread afterward.
* generic/tclIO.c (Tcl_GetChannelThread, lines 1478-1503):
* generic/tcl.decls (Tcl_GetChannelThread, lines 1504-1506): New
API function to retrieve the Id of the managing thread from a
channel. Implementation and declaration.
* generic/tclTest.c (TestChannelCmd, lines 4520-4532): Added
subcommand 'mthread' to query a channel about its managing
thread.
2001-03-29 Mo DeJong <mdejong@redhat.com>
* tests/interp.test: Print out warning when
testinterpdelete command is not defined.
Add tests that checks to make sure a
child interp inherits the parent's cwd.
2001-03-29 Jeff Hobbs <jeffh@gimlet.activestate.com>
* doc/tcltest.n: corrected incorrect macro usage.
* doc/lsort.n: corrected unbalanced nroff macros.
* unix/tclUnixPipe.c (TclpCreateTempFile): prevent potential race
condition and security leak in tmp filename creation.
(max) [Patch #402924]
* unix/configure:
* unix/tcl.m4: corrected IRIX-5.x config to not use -n32.
(english) [Patch #403626]
* unix/tclUnixThrd.c (Tcl_ConditionWait): fixed handling of
timeout for threads (corrects excessive CPU usage issue for Tk on
Unix in threaded Tcl environment). (ruppert) [Bug #411603]
2001-03-29 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/lsort.n: Added some notes that clarify the behaviour of
[lsort] as well as a whole bunch of examples. [Bug #219202]
2001-03-27 Jeff Hobbs <jeffh@gimlet.activestate.com>
* doc/Alloc.3: corrected docs to note that Tcl_Attempt* return
char *'s, not ints. [Bug #411388]
* tests/regexp.test (regexp-19.1):
* generic/tclCmdMZ.c (Tcl_RegsubObjCmd): fixed handling of nulls
in subspec value.
2001-03-26 Don Porter <dgp@users.sourceforge.net>
* generic/tclDecls.h (Tcl_InitCustomHashTable): Correction to
patch from 2001-01-18; tclDecls.h was not generated using
'make genstubs'.
2001-03-26 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* win/tclWinInt.h (tclWinTCharEncoding): Removed as now a static
variable in win/tclWin32Dll.c instead.
2001-03-23 Jeff Hobbs <jeffh@activestate.com>
* generic/tclVar.c (Tcl_ArrayObjCmd): Corrected retrieval of
resultPtr to prevent possible corruption.
* generic/tclNamesp.c (Tcl_Import): Correctly freed a DString.
(lavana) [Patch #403755]
2001-03-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/set-old.test (set-old-7.2): Changed error behaviour of
[unset] to agree with documentation, so must change test as well.
2001-03-14 Don Porter <dgp@users.sourceforge.net>
* library/package.tcl (pkg_mkIndex): Added patch from Vince
Darley to make [pkg_mkIndex -verbose] even more verbose.
[Bug 219349, Patch 403529]
2001-03-13 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* doc/info.n: Improved documentation for [info hostname].
[Bug #403840]
* generic/tclVar.c (Tcl_UnsetObjCmd): Made command behave as
documented [issue remaining from bug #405769]
* generic/tclCmdMZ.c (Tcl_StringObjCmd): A missing
{return TCL_OK;} was causing memory corruption. [Bug #408002]
* generic/tclExecute.c (TclDeleteExecEnv, GrowEvaluationStack,
TclExecuteByteCode): Added some casts to ClientData that are
apparently needed on some architectures.
2001-03-12 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/string.test: Fixed some test numberings and added a test.
[Patch #403229]
2001-03-06 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclVar.c (Tcl_UnsetObjCmd): Rewrote argument parser to
avoid a read off the end of the argument array that could occur
when executing something like [unset -nocomplain] was executed.
Improved the error message given when too few arguments are given
(-nocomplain should obviously be *before* --, not after it) and
also modified the test suite to take account of that and the
documentation to use the same improvement. [Bug 405769]
2001-03-02 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclExecute.c (TclExecuteByteCode): Fixed bug that could
pass pointers to freed memory to command implementations, which
most obviously caused some weird behaviour with [info level], but
could have caused problems with user code and command traces too.
[Bug 404865, Patch 405436]
2001-02-23 msofer <msofer@users.sourceforge.net>
* no changes; fixing up the missing comment in the previous one.
Sorry.
2001-02-23 msofer <msofer@ant.utdt>
* /cvsroot/tcl/tcl/tests/execute.test:
added test for evaluation of an expression in a variable; evals once
by compiling, second time using the previous compilation
2001-02-18 Kevin B. Kenny <kennykb@acm.org>
* doc/clock.n: Updated documentation to reflect the addition of
compat/strftime.c, including the correct formatting of
ISO-8601:1988 fiscal week number (%V).
2001-02-15 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* generic/tclCmdMZ.c (Tcl_SplitObjCmd): Improved efficiency of
splitting strings into individual characters by adding hash so
that only one Tcl_Obj per character is created. Improves
performance of splitting of short strings and makes a huge
difference to splitting of long strings, such as is done in the
mime package in tcllib. [Bug #131523]
2001-01-31 Don Porter <dgp@users.sourceforge.net>
* win/makefile.vc (install-libraries): Corrected misdirected
install directory for the msgcat 1.2 package.
2001-01-30 Don Porter <dgp@users.sourceforge.net>
* generic/tclIO.c (CopyData): Moved code that updates the count
of how many bytes are left to copy. Corrects bug that when
writing occurs in the background, the copy loop could be
escaped without updating the count, causing CopyData() to try
to copy more bytes than the toRead value originally passed to
TclCopyChannel(), leading to hangs and misreporting of number
of bytes copied. [Bug 118203, Patch 103432]
2001-01-18 Andreas Kupries <a.kupries@westend.com>
* Everything below belongs together, it fixes bug #123153.
* generic/tcl.h (line 342): A bit more explanation about the
default value for TCL_PRESERVE_BINARY_COMPATABILITY.
* generic/tcl.h (line 1208): Define the macro 'Tcl_InitHashTable'
only when TCL_PRESERVE_BINARY_COMPATIBILITY is not set
as it kills binary compatibility to 8.3 and earlier
versions. This is the main part of the patch/change.
* generic/tcl.decls (line 1469):
* generic/tclHash.c (Tcl_InitHashTable):
* generic/tclHash.c (Tcl_InitHashTableEx):
* generic/tclObj.c (Tcl_InitObjHashTable): Changed
'Tcl_InitHashTableEx' to 'Tcl_InitCustomHashTable'. This change
is more of an estethical nature, replacing the ubiquitous 'Ex'
suffix with a more meaningful name. The introduced binary
incompatibility is deemed acceptable as it is between alpha
versions. Updated callers.
* doc/Hash.3:
* unix/mkLinks: Changed 'Tcl_InitHashTableEx' to
'Tcl_InitCustomHashTable'.
2001-01-10 Donal K. Fellows <fellowsd@cs.man.ac.uk>
* tests/winPipe.test (winpipe-1.20):
* tests/winDde.test (createChildProcess):
* tests/pkgMkIndex.test (pkgtest::createIndex): Removed
assumption that paths contain no spaces which causes problems with
both [eval] and [open |...] due to the well-known differences
between lists and strings. Fixes bug #119406
2001-01-04 Don Porter <dgp@users.sourceforge.net>
* tests/unixInit.test:
* unix/tclUnixInit.c (TclpInitLibraryPath):
* win/tclWinInit.c (TclpInitLibraryPath): Several entries in
the library path ($tcl_libPath) are determined relative to the
absolute path of the executable. When the executable is
installed in or near the root directory of the file system,
relative pathnames were being incorrectly generated, and in
the worst case, memory access violations were crashing the program.
[Bug 119416, Patch 102972]
******************************************************************
*** 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.4b3 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.39.8.2 2002/08/20 20:25:24 das Exp $
Contents
--------
1. Introduction
2. Documentation
3. Compiling and installing Tcl
4. Development tools
|
| ︙ | ︙ |
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.62.8.2 2002/08/20 20:25:24 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 |
| ︙ | ︙ | |||
5434 5435 5436 5437 5438 5439 5440 |
*** POTENTIAL INCOMPATIBILITY ***
2002-03-04 (bug fix)[474358, 218099, 219314, 524674] fixed several problems
related to the handling of iso2022 text and finalization of escape-based
encodings. (taguchi, takahashi, hobbs)
--- Released 8.4a4, March 5, 2002 --- See ChangeLog for details ---
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*** POTENTIAL INCOMPATIBILITY ***
2002-03-04 (bug fix)[474358, 218099, 219314, 524674] fixed several problems
related to the handling of iso2022 text and finalization of escape-based
encodings. (taguchi, takahashi, hobbs)
--- Released 8.4a4, March 5, 2002 --- See ChangeLog for details ---
2002-03-06 (new feature)[TIP 80] expanded [lsearch] options (wilkason, fellows)
2002-03-07 (new feature)[TIP 87] [interp recursionlimit] (trier)
2002-03-08 (platform feature) mingw 1.1 build favored (dejong)
2002-03-20 (new feature)[TIP 27] CONST-ified variable access functions (porter)
2002-03-24 (bug fix)[511666,511658,523217,530960] expanded
Tcl_FSMatchInDirectory to handle assorted [glob] bugs in VFS. (darley)
*** POTENTIAL INCOMPATIBILITY with prior 8.4a releases ***
2002-03-25 (bug fix)[495726] stopped tcltest disabling of auto-loading (porter)
2002-03-25 (bug fix)[495977] allow \n in test constraints (porter)
2002-03-27 (platform support)[527941,533862] VC/winhelp/W9X (spjuth,
gravereaux)
2002-03-28 (bug fix)[219181] exception at level 0 issues (sofer)
2002-03-28 (bug fix)[219362] command termination; Tcl_CreateTrace (knoll,sofer)
2002-04-05 (bug fix)[536879] exceptions during variable subst (porter)
2002-04-15 (bug fix)[497446,513983] tcltest syntax errors now raised (porter)
***POTENTIAL INCOMPATIBILITY with prior tcltest 2.0.* (8.4aX)***
2002-04-17 (bug fix)[495660] [(save|restore)state] deprecated (porter)
2002-04-17 (bug fix)[526524] escape-based encodings corrected (yamamoto, hobbs)
2002-04-18 (bug fix)[542588] [expr] error msgs improved (ehrens, sofer)
2002-04-18 (bug fix)[545325] [info level $level] now returns [namespace eval]
as documented (suchenwirth,sofer)
2002-04-19 (bug fix)[544727] export [mcload]; ns context of [mcmax] (porter)
=> msgcat 1.2.3
2002-04-22 (performance enhancement) threaded memory allocator (AOL, hobbs)
2002-04-24 (new feature) TCLTK_NO_LIBRARY_TEXT_RESOURCES #define disables
inclusion of tcl library code in resource fork on Mac. (steffen)
2002-05-21 (platform support) static libs on OSF (dejong)
2002-05-24 (bug fix)[557878] set encoding on listening socket (staplin,
kupries)
2002-05-24 (new feature)[TIP 91] Tcl_Seek compatibility (fellows)
2002-05-28 (bug fix)[545579] VFS [load] left temp file (darley)
2002-05-28 (bug fix)[559376] plug timezone env leak on Windows (hobbs)
2002-05-29 (performance enhancement) [string compare] optimized (hobbs,fellows)
2002-05-31 (bug fix)[550534] plug interp leak in [pkg_mkIndex] (helmut)
2002-05-31 (dead code)[474335,555635] removed all use of matherr() (english)
*** POTENTIAL INCOMPATIBILITY ***
2002-06-04 (new feature)[TIP 85,521362] custom result match in tcltest
(markus, porter)
=> tcltest 2.1
2002-06-06 (bug fix)[524352] encoding, threading, and environment issues on
MacOSX (steffen)
2002-06-06 (bug fix)[512214,558742,512214,461000] lazy initialization of
tcltest constraints (porter)
2002-06-07 (bug fix)[563122,564595] EOVERFLOW definitions (fellows)
2002-06-11 (bug fix)[567386] [info locals] corrections (sofer)
2002-06-14 (new feature)[TIP 102] [trace list] renamed [trace info] (fellows)
2002-06-17 (new feature)[525522,525525] msgcat support for XPG4 locales;
examination of LC_ALL, LC_MESSAGES environment variables (haible, porter)
=> msgcat 1.3
2002-06-17 (new feature)[565088] header files assume modern C compiler by
default; older compilers may need configuration (english)
*** POTENTIAL INCOMPATIBILITY ***
2002-06-17 (bug fix)[554068] [exec] argument quoting on Windows (darley)
2002-06-17 (new feature)[TIP 62,462580] command execution traces (lavana)
2002-06-19 (bug fix)[558324] regexp sets a linked variable (watson)
* (performance enhancment) optimizations of bytecode execution (sofer)
2002-06-21 (new feature)[TIP 99,562970] new [file link] command (darley)
2002-06-24 (new feature)[TIP 101] new [tcltest::configure] command (porter)
2002-06-25 (new feature) --enable-man-symlinks and --enable-man-compression
options to configure (max)
2002-06-26 (bug fix)[565880] [clock format] now respects locale (max)
*** POTENTIAL INCOMPATIBILITY ***
2002-07-03 (bug fix)[577015] [catch] catches even compile errors (sofer)
--- Released 8.4b1, July 5, 2002 --- See ChangeLog for details ---
|
Changes to doc/Access.3.
1 2 3 4 5 6 | '\" '\" 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. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" 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. '\" '\" RCS: @(#) $Id: Access.3,v 1.4.8.3 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_Access 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Access, Tcl_Stat \- check file permissions and other attributes .SH SYNOPSIS |
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | \fBTcl_Stat\fR, wherever possible. .PP There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR rather than calling system level functions \fBaccess\fR and \fBstat\fR directly. First, the Windows implementation of both functions fixes some bugs in the system level calls. Second, both \fBTcl_Access\fR and \fBTcl_Stat\fR (as well as \fBTcl_OpenFileChannelProc\fR) hook | | | | 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 | \fBTcl_Stat\fR, wherever possible. .PP There are two reasons for calling \fBTcl_Access\fR and \fBTcl_Stat\fR rather than calling system level functions \fBaccess\fR and \fBstat\fR directly. First, the Windows implementation of both functions fixes some bugs in the system level calls. Second, both \fBTcl_Access\fR and \fBTcl_Stat\fR (as well as \fBTcl_OpenFileChannelProc\fR) hook into a linked list of functions. This allows the possibility to reroute file access to alternative media or access methods. .PP \fBTcl_Access\fR checks whether the process would be allowed to read, write or test for existence of the file (or other file system object) whose name is pathname. If pathname is a symbolic link on Unix, then permissions of the file referred by this symbolic link are tested. .PP On success (all requested permissions granted), zero is returned. On error (at least one bit in mode asked for a permission that is denied, or some other error occurred), -1 is returned. .PP \fBTcl_Stat\fR fills the stat structure \fIstatPtr\fR with information about the specified file. You do not need any access rights to the file to get this information but you need search rights to all directories named in the path leading to the file. The stat structure includes info regarding device, inode (always 0 on Windows), privilege mode, nlink (always 1 on Windows), user id (always 0 on Windows), group id (always 0 on Windows), rdev (same as device on Windows), size, last access time, last modification time, and creation time. .PP If \fIpath\fR exists, \fBTcl_Stat\fR returns 0 and the stat structure is filled with data. Otherwise, -1 is returned, and no stat info is given. .SH KEYWORDS stat, access |
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.5.14.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | If negative, all bytes up to the first null byte are used. .AP Tcl_Obj *errorObjPtr in This variable \fBerrorCode\fR will be set to this value. .AP char *element in String to record as one element of \fBerrorCode\fR variable. Last \fIelement\fR argument must be NULL. .AP va_list argList in | | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | If negative, all bytes up to the first null byte are used. .AP Tcl_Obj *errorObjPtr in This variable \fBerrorCode\fR will be set to this value. .AP char *element in String to record as one element of \fBerrorCode\fR variable. Last \fIelement\fR argument must be NULL. .AP va_list argList in 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 |
| ︙ | ︙ | |||
151 152 153 154 155 156 157 | in \fBerrorCode\fR). It may be convenient to include this string as part of the error message returned to the application in the interpreter's result. .PP \fBTcl_LogCommandInfo\fR is invoked after an error occurs in an interpreter. It adds information about the command that was being | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | in \fBerrorCode\fR). It may be convenient to include this string as part of the error message returned to the application in the interpreter's result. .PP \fBTcl_LogCommandInfo\fR is invoked after an error occurs in an interpreter. It adds information about the command that was being executed when the error occurred to the \fBerrorInfo\fR variable, and the line number stored internally in the interpreter is set. On the first call to \fBTcl_LogCommandInfo\fR or \fBTcl_AddObjErrorInfo\fR since an error occurred, the old information in \fBerrorInfo\fR is deleted. .PP It is important to call the procedures described here rather than setting \fBerrorInfo\fR or \fBerrorCode\fR directly with |
| ︙ | ︙ |
Changes to doc/Alloc.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: Alloc.3,v 1.5.12.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_Alloc 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory .SH SYNOPSIS |
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that \fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl interpreter to \fBpanic\fR if the memory allocation fails. If the allocation fails, these functions will return NULL. .PP The procedures \fBckalloc\fR, \fBckfree\fR, \fBckrealloc\fR, \fBattemptckalloc\fR, and \fBattemptckrealloc\fR are implemented | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that \fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl interpreter to \fBpanic\fR if the memory allocation fails. If the allocation fails, these functions will return NULL. .PP The procedures \fBckalloc\fR, \fBckfree\fR, \fBckrealloc\fR, \fBattemptckalloc\fR, and \fBattemptckrealloc\fR are implemented as macros. Normally, they are synonyms for the corresponding procedures documented on this page. When Tcl and all modules calling Tcl are compiled with \fBTCL_MEM_DEBUG\fR defined, however, these macros are redefined to be special debugging versions of of these procedures. To support Tcl's memory debugging within a module, use the macros rather than direct calls to \fBTcl_Alloc\fR, etc. .SH KEYWORDS alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG |
Changes to doc/Backslash.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: Backslash.3,v 1.3.28.1 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Backslash \- parse a backslash sequence .SH SYNOPSIS |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | .SH DESCRIPTION .PP .VS 8.1 The use of \fBTcl_Backslash\fR is deprecated in favor of \fBTcl_UtfBackslash\fR. .PP | | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | .SH DESCRIPTION .PP .VS 8.1 The use of \fBTcl_Backslash\fR is deprecated in favor of \fBTcl_UtfBackslash\fR. .PP This is a utility procedure provided for backwards compatibility with non-internationalized Tcl extensions. It parses a backslash sequence and returns the low byte of the Unicode character corresponding to the sequence. .VE \fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of characters in the backslash sequence. .PP See the Tcl manual entry for information on the valid backslash sequences. |
| ︙ | ︙ |
Changes to doc/BoolObj.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: BoolObj.3,v 1.2.34.1 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_BooleanObj 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_NewBooleanObj, Tcl_SetBooleanObj, Tcl_GetBooleanFromObj \- manipulate Tcl objects as boolean values .SH SYNOPSIS |
| ︙ | ︙ | |||
71 72 73 74 75 76 77 78 79 80 81 82 83 | If an error occurs during conversion, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result object unless \fIinterp\fR is NULL. Otherwise, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR and stores the boolean value in the address given by \fIboolPtr\fR. If the object is not already a boolean object, the conversion will free any old internal representation. .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS boolean, boolean object, boolean type, internal representation, object, object type, string representation | > > > > > > | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | If an error occurs during conversion, it returns \fBTCL_ERROR\fR and leaves an error message in the interpreter's result object unless \fIinterp\fR is NULL. Otherwise, \fBTcl_GetBooleanFromObj\fR returns \fBTCL_OK\fR and stores the boolean value in the address given by \fIboolPtr\fR. If the object is not already a boolean object, the conversion will free any old internal representation. Objects having a string representation equal to any of \fB0\fR, \fBfalse\fR, \fBno\fR, or \fBoff\fR have a boolean value 0; if the string representation is any of \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR the boolean value is 1. Any of these string values may be abbreviated, and upper-case spellings are also acceptable. .SH "SEE ALSO" Tcl_NewObj, Tcl_DecrRefCount, Tcl_IncrRefCount, Tcl_GetObjResult .SH KEYWORDS boolean, boolean object, boolean type, internal representation, object, object type, string representation |
Changes to doc/CmdCmplt.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 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | '\" '\" 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: CmdCmplt.3,v 1.2.34.1 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_CommandComplete 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CommandComplete \- Check for unmatched braces in a Tcl command .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_CommandComplete\fR(\fIcmd\fR) .SH ARGUMENTS .AS "CONST char" *cmd .AP "CONST char" *cmd in Command string to test for completeness. .BE .SH DESCRIPTION .PP \fBTcl_CommandComplete\fR takes a Tcl command string as argument and determines whether it contains one or more |
| ︙ | ︙ |
Changes to doc/Concat.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 16 17 18 19 20 21 22 23 24 25 26 | '\" '\" 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: Concat.3,v 1.3.2.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_Concat 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Concat \- concatenate a collection of strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp CONST char * \fBTcl_Concat\fR(\fIargc, argv\fR) .SH ARGUMENTS .AP int argc in Number of strings. .AP "CONST char * CONST" argv[] in Array of strings to concatenate. Must have \fIargc\fR entries. .BE |
| ︙ | ︙ |
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 | '\" '\" 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.11.4.3 2002/08/20 20:25:24 das Exp $ .so man.macros .TH Tcl_CreateChannel 3 8.3 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_IsChannelShared, Tcl_IsChannelRegistered, Tcl_CutChannel, Tcl_SpliceChannel, Tcl_IsChannelExisting, Tcl_ClearChannelHandlers, Tcl_GetChannelThread, Tcl_ChannelBuffered \- procedures for creating and manipulating channels .SH SYNOPSIS |
| ︙ | ︙ | |||
270 271 272 273 274 275 276 | buffers for the stack of channels the supplied channel is part of. .PP .VS 8.4 \fBTcl_IsChannelShared\fR checks the refcount of the specified \fIchannel\fR and returns whether the \fIchannel\fR was shared among multiple interpreters (result == 1) or not (result == 0). .PP | | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | buffers for the stack of channels the supplied channel is part of. .PP .VS 8.4 \fBTcl_IsChannelShared\fR checks the refcount of the specified \fIchannel\fR and returns whether the \fIchannel\fR was shared among multiple interpreters (result == 1) or not (result == 0). .PP \fBTcl_IsChannelRegistered\fR checks whether the specified \fIchannel\fR is registered in the given \fIinterp\fRreter (result == 1) or not (result == 0). .PP \fBTcl_IsChannelExisting\fR checks whether a channel with the specified 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. |
| ︙ | ︙ | |||
756 757 758 759 760 761 762 | .PP This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns a pointer to the function. .SH HANDLERPROC .PP The \fIhandlerProc\fR field contains the address of a function called by | | | | 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 | .PP This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns a pointer to the function. .SH HANDLERPROC .PP The \fIhandlerProc\fR field contains the address of a function called by the generic layer to notify the channel that an event occurred. It should be defined for stacked channel drivers that wish to be notified of events that occur on the underlying (stacked) channel. \fIHandlerProc\fR should match the following prototype: .PP .CS typedef int Tcl_DriverHandlerProc( ClientData \fIinstanceData\fR, int \fIinterestMask\fR); .CE .PP \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 |
| ︙ | ︙ |
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.4.12.1 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_CreateCommand 3 "" Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateCommand \- implement new commands in C .SH SYNOPSIS |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 | \fIProc\fR should have arguments and result that match the type \fBTcl_CmdProc\fR: .CS typedef int Tcl_CmdProc( ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIargc\fR, | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | \fIProc\fR should have arguments and result that match the type \fBTcl_CmdProc\fR: .CS typedef int Tcl_CmdProc( ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIargc\fR, CONST char *\fIargv\fR[]); .CE When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR parameters will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to \fBTcl_CreateCommand\fR. Typically, \fIclientData\fR points to an application-specific data structure that describes what to do when the command procedure is invoked. \fIArgc\fR and \fIargv\fR describe the arguments to |
| ︙ | ︙ |
Changes to doc/CrtInterp.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: CrtInterp.3,v 1.5.18.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters .SH SYNOPSIS |
| ︙ | ︙ | |||
99 100 101 102 103 104 105 | \fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around all uses of the interpreter. Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR has been called. To ensure that the interpreter is properly deleted when it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other code already called \fBTcl_DeleteInterp\fR; if not, call \fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fR in your own code. | < < | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | \fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around all uses of the interpreter. Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR has been called. To ensure that the interpreter is properly deleted when it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other code already called \fBTcl_DeleteInterp\fR; if not, call \fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fR in your own code. .TP Retrieving An Interpreter From A Data Structure When an interpreter is retrieved from a data structure (e.g. the client data of a callback) for use in \fBTcl_Eval\fR, \fBTcl_VarEval\fR, \fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or \fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around all uses of the interpreter; it is unsafe to reuse the interpreter once |
| ︙ | ︙ |
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.5.12.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | Name of source command for alias. .AP Tcl_Interp *targetInterp in Interpreter that contains the target command for an alias. .AP "CONST char" *targetCmd in Name of target command for alias in \fItargetInterp\fR. .AP int argc in Count of additional arguments to pass to the alias command. | | | | | 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 | Name of source command for alias. .AP Tcl_Interp *targetInterp in Interpreter that contains the target command for an alias. .AP "CONST char" *targetCmd in Name of target command for alias in \fItargetInterp\fR. .AP int argc in Count of additional arguments to pass to the alias command. .AP "CONST char * CONST" *argv in Vector of strings, the additional arguments to pass to the alias command. This storage is owned by the caller. .AP int objc in Count of additional object arguments to pass to the alias object command. .AP Tcl_Object **objv in Vector of Tcl_Obj structures, the additional object arguments to pass to the alias object command. This storage is owned by the caller. .AP Tcl_Interp **targetInterpPtr in Pointer to location to store the address of the interpreter where a target command is defined for an alias. .AP "CONST char" **targetCmdPtr out Pointer to location to store the address of the name of the target command for an alias. .AP int *argcPtr out Pointer to location to store count of additional arguments to be passed to the alias. The location is in storage owned by the caller. .AP "CONST char" ***argvPtr out Pointer to location to store a vector of strings, the additional arguments to pass to an alias. The location is in storage owned by the caller, the vector of strings is owned by the called function. .AP int *objcPtr out Pointer to location to store count of additional object arguments to be passed to the alias. The location is in storage owned by the caller. .AP Tcl_Obj ***objvPtr out |
| ︙ | ︙ | |||
227 228 229 230 231 232 233 | For a description of the Tcl interface to multiple interpreters, see \fIinterp(n)\fR. .SH "SEE ALSO" interp .SH KEYWORDS alias, command, exposed commands, hidden commands, interpreter, invoke, | | < | 227 228 229 230 231 232 233 234 | For a description of the Tcl interface to multiple interpreters, see \fIinterp(n)\fR. .SH "SEE ALSO" interp .SH KEYWORDS alias, command, exposed commands, hidden commands, interpreter, invoke, master, slave |
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.2.34.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | .sp \fBTcl_DeleteTrace\fR(\fIinterp, trace\fR) .SH ARGUMENTS .AS Tcl_CmdObjTraceDeleteProc (clientData)() .AP Tcl_Interp *interp in Interpreter containing command to be traced or untraced. .AP int level in | | > > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | .sp \fBTcl_DeleteTrace\fR(\fIinterp, trace\fR) .SH ARGUMENTS .AS Tcl_CmdObjTraceDeleteProc (clientData)() .AP Tcl_Interp *interp in Interpreter containing command to be traced or untraced. .AP int level in Only commands at or below this nesting level will be traced unless 0 is specified. 1 means top-level commands only, 2 means top-level commands or those that are invoked as immediate consequences of executing top-level commands (procedure bodies, bracketed commands, etc.) and so on. A value of 0 means that commands at any level are traced. .AP int flags in Flags governing the trace execution. See below for details. .AP Tcl_CmdObjTraceProc *objProc in Procedure to call for each command that's executed. See below for details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that's executed. See below for |
| ︙ | ︙ | |||
159 160 161 162 163 164 165 | ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIlevel\fR, char *\fIcommand\fR, Tcl_CmdProc *\fIcmdProc\fR, ClientData \fIcmdClientData\fR, int \fIargc\fR, | | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 | ClientData \fIclientData\fR, Tcl_Interp *\fIinterp\fR, int \fIlevel\fR, char *\fIcommand\fR, Tcl_CmdProc *\fIcmdProc\fR, ClientData \fIcmdClientData\fR, int \fIargc\fR, CONST char *\fIargv\fR[]); .CE The parameters to the \fIproc\fR callback are similar to those of the \fIobjProc\fR callback above. The \fIcommandToken\fR is replaced with \fIcmdProc\fR, a pointer to the (string-based) command procedure that will be invoked; and \fIcmdClientData\fR, the client data that will be passed to the procedure. The \fIobjc\fR parameter is replaced with an \fIargv\fR parameter, that gives the arguments to |
| ︙ | ︙ |
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.7.18.3 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
240 241 242 243 244 245 246 | If you planned to use the same "char" based interfaces on both Windows 95 and Windows NT, you could use \fBTcl_UtfToExternal\fR and \fBTcl_ExternalToUtf\fR (or their \fBTcl_DString\fR equivalents) with an encoding of NULL (the current system encoding). On the other hand, if you planned to use the Unicode interface when running on Windows NT and the "char" interfaces when running on Windows 95, you would have to perform the following type of test over and over in your program | | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
If you planned to use the same "char" based interfaces on both Windows
95 and Windows NT, you could use \fBTcl_UtfToExternal\fR and
\fBTcl_ExternalToUtf\fR (or their \fBTcl_DString\fR equivalents) with an
encoding of NULL (the current system encoding). On the other hand,
if you planned to use the Unicode interface when running on Windows NT
and the "char" interfaces when running on Windows 95, you would have
to perform the following type of test over and over in your program
(as represented in pseudo-code):
.CS
if (running NT) {
encoding <- Tcl_GetEncoding("unicode");
nativeBuffer <- Tcl_UtfToExternal(encoding, utfBuffer);
Tcl_FreeEncoding(encoding);
} else {
nativeBuffer <- Tcl_UtfToExternal(NULL, utfBuffer);
|
| ︙ | ︙ |
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.9.14.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | .AP Tcl_Obj **objv in 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. | | < < | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | .AP Tcl_Obj **objv in 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 |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObjEx\fR. .PP \fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to be executed is supplied as a string instead of an object and no compilation occurs. The string should be a proper UTF-8 string as converted by \fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 | \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObjEx\fR. .PP \fBTcl_Eval\fR is similar to \fBTcl_EvalObjEx\fR except that the script to be executed is supplied as a string instead of an object and no compilation occurs. The string should be a proper UTF-8 string as converted by \fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known to possibly contain upper ASCII characters who's possible combinations might be a UTF-8 special code. The string is parsed and executed directly (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like \fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before Tcl 8.0, \fBTcl_Eval\fR copies the object result in \fIinterp\fR to |
| ︙ | ︙ |
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.4.12.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | .SH ARGUMENTS .AS Tcl_Interp *booleanPtr .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\fR. .VS 8.4 .AP "CONST char" *string in .VE | | < < | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | .SH ARGUMENTS .AS Tcl_Interp *booleanPtr .AP Tcl_Interp *interp in Interpreter in whose context to evaluate \fIstring\fR or \fIobjPtr\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. .AP int *doublePtr out Pointer to location in which to store the floating-point value of the expression. .AP int *booleanPtr out |
| ︙ | ︙ |
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.8.2.3 2002/08/20 20:25:24 das 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 70 71 72 73 74 | 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 int \fBTcl_FSLstat\fR(\fIpathPtr, statPtr\fR) .sp int \fBTcl_FSUtime\fR(\fIpathPtr, tval\fR) .sp |
| ︙ | ︙ | |||
253 254 255 256 257 258 259 | a lookup table of functions to implement all or some of the functionality listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls abstract away from what the 'struct stat' buffer buffer is actually declared to be, allowing the same code to be used both on systems with and systems without support for files larger than 2GB in size. .PP The \fBTcl_FS...\fR are objectified and may cache internal | | | | > | | | | > > > | | | | > > | 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 | a lookup table of functions to implement all or some of the functionality listed here. Finally, the \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR calls abstract away from what the 'struct stat' buffer buffer is actually declared to be, allowing the same code to be used both on systems with and systems without support for files larger than 2GB in size. .PP The \fBTcl_FS...\fR are objectified and may cache internal representations and other path-related strings (e.g. the current working directory). One side-effect of this is that one must not pass in objects with a refCount of zero to any of these functions. If such calls were handled, they might result in memory leaks (under some circumstances, the filesystem code may wish to retain a reference to the passed in object, and so one must not assume that after any of these calls return, the object still has a refCount of zero - it may have been incremented), or in a direct segfault due to the object being freed part way through the complex object manipulation required to ensure that the path is fully normalized and absolute for filesystem determination. The practical lesson to learn from this is that \fBTcl_Obj *path = Tcl_NewStringObj(...) ; Tcl_FS...(path) ; Tcl_DecrRefCount(path)\fR is wrong, and may segfault. The 'path' must have its refCount incremented before passing it in, or decrementing it. For this reason, objects with a refCount of zero are considered not to be valid filesystem paths and calling any Tcl_FS API with such an object will result in no action being taken. .PP \fBTcl_FSCopyFile\fR attempts to copy the file given by srcPathPtr to the path name given by destPathPtr. If the two paths given lie in the same filesystem (according to \fBTcl_FSGetFileSystemForPath\fR) then that filesystem's 'copy file' function is called (if it is non-NULL). Otherwise the function returns -1 and sets Tcl's errno to the 'EXDEV' posix error code (which signifies a 'cross-domain link'). |
| ︙ | ︙ | |||
339 340 341 342 343 344 345 | Note that the 'glob' code implements recursive patterns internally, so this function will only ever be passed simple patterns, which can be matched using the logic of 'string match'. To handle recursion, Tcl will call this function frequently asking only for directories to be returned. .PP | | < | | | | | | | > > > | > > | | 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 | Note that the 'glob' code implements recursive patterns internally, so this function will only ever be passed simple patterns, which can be matched using the logic of 'string match'. To handle recursion, Tcl will call this function frequently asking only for directories to be returned. .PP \fBTcl_FSLink\fR replaces the library version of readlink(), and extends it to support the creation of links. The appropriate function for the filesystem to which linkNamePtr belongs will be called. .PP If the \fItoPtr\fR is NULL, a readlink action is performed. The result is a Tcl_Obj specifying the contents of the symbolic link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller, which should call Tcl_DecrRefCount when the result is no longer needed. If the \fItoPtr\fR is not NULL, Tcl should create a link of one of the types passed in in the \fIlinkAction\fR flag. This flag is an or'd combination of TCL_CREATE_SYMBOLIC_LINK and TCL_CREATE_HARD_LINK. Where a choice exists (i.e. more than one flag is passed in), the Tcl convention is to prefer symbolic links. When a link is successfully created, the return value should be \fItoPtr\fR (which is therefore already owned by the caller). If unsuccessful, NULL should be returned. .PP \fBTcl_FSLstat\fR fills the stat structure \fIstatPtr\fR with information about the specified file. You do not need any access rights to the file to get this information but you need search rights to all directories named in the path leading to the file. The stat structure includes info regarding device, inode (always 0 on Windows), privilege mode, nlink (always 1 on Windows), user id (always 0 on |
| ︙ | ︙ | |||
424 425 426 427 428 429 430 | .PP \fBTcl_FSOpenFileChannel\fR opens a file specified by \fIpathPtr\fR and returns a channel handle that can be used to perform input and output on the file. This API is modeled after the \fBfopen\fR procedure of the Unix standard I/O library. The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file. | | | | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 | .PP \fBTcl_FSOpenFileChannel\fR opens a file specified by \fIpathPtr\fR and returns a channel handle that can be used to perform input and output on the file. This API is modeled after the \fBfopen\fR procedure of the Unix standard I/O library. The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file. If an error occurs while opening the channel, \fBTcl_FSOpenFileChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, \fBTcl_FSOpenFileChannel\fR leaves an error message in \fIinterp\fR's result after any error. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR, described below. If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. |
| ︙ | ︙ | |||
945 946 947 948 949 950 951 | which require open or accessing a file's contents will use it (e.g. \fBopen\fR, \fBencoding\fR, and many Tk commands). .PP .CS typedef Tcl_Channel Tcl_FSOpenFileChannelProc( Tcl_Interp *\fIinterp\fR, Tcl_Obj *\fIpathPtr\fR, | | | | | > | | | | | | | 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 | which require open or accessing a file's contents will use it (e.g. \fBopen\fR, \fBencoding\fR, and many Tk commands). .PP .CS typedef Tcl_Channel Tcl_FSOpenFileChannelProc( Tcl_Interp *\fIinterp\fR, Tcl_Obj *\fIpathPtr\fR, int \fImode\fR, int \fIpermissions\fR); .CE .PP The \fBTcl_FSOpenFileChannelProc\fR opens a file specified by \fIpathPtr\fR and returns a channel handle that can be used to perform input and output on the file. This API is modeled after the \fBfopen\fR procedure of the Unix standard I/O library. The syntax and meaning of all arguments is similar to those given in the Tcl \fBopen\fR command when opening a file, where the \fImode\fR argument is a combination of the POSIX flags O_RDONLY, O_WRONLY, etc. If an error occurs while opening the channel, the \fBTcl_FSOpenFileChannelProc\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, if \fIinterp\fR is non-NULL, the \fBTcl_FSOpenFileChannelProc\fR leaves an error message in \fIinterp\fR's result after any error. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR. If one of the standard channels, \fBstdin, stdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. .SH MATCHINDIRECTORYPROC |
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 | occurred in the matching process. Error messages are placed in interp, but on a TCL_OK result, the interpreter should not be modified, but rather results should be added to the \fIresult\fR object given (which can be assumed to be a valid 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 | | | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 | occurred in the matching process. Error messages are placed in interp, but on a TCL_OK result, the interpreter should not be modified, but rather results should be added to the \fIresult\fR object given (which can be assumed to be a valid 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. .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 |
| ︙ | ︙ | |||
1026 1027 1028 1029 1030 1031 1032 | .SH LINKPROC .PP Function to process a \fBTcl_FSLink()\fR call. Should be implemented only if the filesystem supports links, and may otherwise be NULL. .PP .CS typedef Tcl_Obj* Tcl_FSLinkProc( | | | > | | > > | 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 | .SH LINKPROC .PP Function to process a \fBTcl_FSLink()\fR call. Should be implemented only if the filesystem supports links, and may otherwise be NULL. .PP .CS typedef Tcl_Obj* Tcl_FSLinkProc( Tcl_Obj *\fIlinkNamePtr\fR, Tcl_Obj *\fItoPtr\fR, int \fIlinkAction\fR); .CE .PP If \fItoPtr\fR is NULL, the function is being asked to read the contents of a link. The result is a Tcl_Obj specifying the contents of the link given by \fIlinkNamePtr\fR, or NULL if the link could not be read. The result is owned by the caller, which should call Tcl_DecrRefCount when the result is no longer needed. If \fItoPtr\fR is not NULL, the function should attempt to create a link. The result in this case should be \fItoPtr\fR if the link was successful and NULL otherwise. In this case the result is not owned by the caller. See the documentation for \fBTcl_FSLink\fR for the correct interpretation of the \fIlinkAction\fR flags. .SH LISTVOLUMESPROC .PP Function to list any filesystem volumes added by this filesystem. Should be implemented only if the filesystem adds volumes at the head of the filesystem, so that they can be returned by 'file volumes'. .PP .CS |
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 | .CS typedef int Tcl_FSDeleteFileProc( Tcl_Obj *\fIpathPtr\fR); .CE .PP The return value is a standard Tcl result indicating whether an error occurred in the process. If successful, the file specified by | | > > > | 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 | .CS typedef int Tcl_FSDeleteFileProc( Tcl_Obj *\fIpathPtr\fR); .CE .PP The return value is a standard Tcl result indicating whether an error occurred in the process. If successful, the file specified by \fIpathPtr\fR should have been removed from the filesystem. Note that, if the filesystem supports symbolic links, Tcl will always call this function and not Tcl_FSRemoveDirectoryProc when needed to delete them (even if they are symbolic links to directories). .SH "FILESYSTEM EFFICIENCY" .PP .SH LSTATPROC .PP Function to process a \fBTcl_FSLstat()\fR call. If not implemented, Tcl will attempt to use the \fIstatProc\fR defined above instead. Therefore it need only be implemented if a filesystem can differentiate between |
| ︙ | ︙ | |||
1203 1204 1205 1206 1207 1208 1209 | .CE .PP The return value is a standard Tcl result indicating whether an error occurred in the copying process. Note that, \fIdestPathPtr\fR is the name of the file which should become the copy of \fIsrcPathPtr\fR. It is never the name of a directory into which \fIsrcPathPtr\fR could be copied (i.e. the function is much simpler than the Tcl level 'file | | > > > | 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 | .CE .PP The return value is a standard Tcl result indicating whether an error occurred in the copying process. Note that, \fIdestPathPtr\fR is the name of the file which should become the copy of \fIsrcPathPtr\fR. It is never the name of a directory into which \fIsrcPathPtr\fR could be copied (i.e. the function is much simpler than the Tcl level 'file copy' subcommand). Note that, if the filesystem supports symbolic links, Tcl will always call this function and not Tcl_FSCopyDirectoryProc when needed to copy them (even if they are symbolic links to directories). .SH RENAMEFILEPROC .PP Function to process a \fBTcl_FSRenameFile()\fR call. If not implemented, Tcl will fall back on a copy and delete mechanism. Therefore it need only be implemented if the filesystem can perform that action more efficiently. .PP |
| ︙ | ︙ | |||
1254 1255 1256 1257 1258 1259 1260 | return TCL_ERROR to disable load functionality in this filesystem entirely. .PP .CS typedef int Tcl_FSLoadFileProc( Tcl_Interp * \fIinterp\fR, Tcl_Obj *\fIpathPtr\fR, | | < < < < | < | | | | 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 | return TCL_ERROR to disable load functionality in this filesystem entirely. .PP .CS typedef int Tcl_FSLoadFileProc( Tcl_Interp * \fIinterp\fR, Tcl_Obj *\fIpathPtr\fR, Tcl_LoadHandle * \fIhandlePtr\fR, Tcl_FSUnloadFileProc * \fIunloadProcPtr\fR); .CE .PP Returns a standard Tcl completion code. If an error occurs, an error message is left in the interp's result. The function dynamically loads a binary code file into memory. On a successful load, the \fIhandlePtr\fR should be filled with a token for the dynamically loaded file, and the \fIunloadProcPtr\fR should be filled in with the address of a procedure. The procedure will be called with the given Tcl_LoadHandle as its only parameter when Tcl needs to unload the file. .SH UNLOADFILEPROC .PP Function to unload a previously successfully loaded file. If load was implemented, then this should also be implemented, if there is any cleanup action required. .PP .CS typedef void Tcl_FSUnloadFileProc( Tcl_LoadHandle \fIloadHandle\fR); .CE .SH GETCWDPROC .PP Function to process a \fBTcl_FSGetCwd()\fR call. Most filesystems need not implement this. It will usually only be called once, if 'getcwd' is called before 'chdir'. May be NULL. .PP |
| ︙ | ︙ |
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.8.14.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | previous call to \fBTcl_InitHashTable\fR). .AP int keyType in Kind of keys to use for new hash table. Must be either TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, TCL_CUSTOM_TYPE_KEYS, TCL_CUSTOM_PTR_KEYS, or an integer value greater than 1. .AP Tcl_HashKeyType *typePtr in Address of structure which defines the behaviour of the hash table. | | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | previous call to \fBTcl_InitHashTable\fR). .AP int keyType in Kind of keys to use for new hash table. Must be either TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, TCL_CUSTOM_TYPE_KEYS, TCL_CUSTOM_PTR_KEYS, or an integer value greater than 1. .AP Tcl_HashKeyType *typePtr in Address of structure which defines the behaviour of the hash table. .AP "CONST char" *key in Key to use for probe into table. Exact form depends on \fIkeyType\fR used to create table. .AP int *newPtr out The word at \fI*newPtr\fR is set to 1 if a new entry was created and 0 if there was already an entry for \fIkey\fR. .AP Tcl_HashEntry *entryPtr in Pointer to hash table entry. |
| ︙ | ︙ |
Changes to doc/InitStubs.3.
1 2 3 4 5 6 | '\" '\" 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. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | '\" '\" 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. '\" '\" RCS: @(#) $Id: InitStubs.3,v 1.6.4.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_InitStubs 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_InitStubs \- initialize the Tcl stubs mechanism .SH SYNOPSIS |
| ︙ | ︙ | |||
82 83 84 85 86 87 88 | extension is indicating that newer versions of Tcl are acceptable as long as they have the same major version number as \fIversion\fR; non-zero means that only the specified \fIversion\fR is acceptable. \fBTcl_InitStubs\fR returns a string containing the actual version of Tcl satisfying the request, or NULL if the Tcl version is not acceptable, does not support stubs, or any other error condition occurred. .SH "SEE ALSO" | | | 82 83 84 85 86 87 88 89 90 91 | extension is indicating that newer versions of Tcl are acceptable as long as they have the same major version number as \fIversion\fR; non-zero means that only the specified \fIversion\fR is acceptable. \fBTcl_InitStubs\fR returns a string containing the actual version of Tcl satisfying the request, or NULL if the Tcl version is not acceptable, does not support stubs, or any other error condition occurred. .SH "SEE ALSO" Tk_InitStubs .SH KEYWORDS stubs |
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.3.18.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | .sp \fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR) .SH ARGUMENTS .AS Tcl_Interp writable .AP Tcl_Interp *interp in Interpreter that contains \fIvarName\fR. Also used by \fBTcl_LinkVar\fR to return error messages. | | | < | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | .sp \fBTcl_UpdateLinkedVar\fR(\fIinterp, varName\fR) .SH ARGUMENTS .AS Tcl_Interp writable .AP Tcl_Interp *interp in Interpreter that contains \fIvarName\fR. Also used by \fBTcl_LinkVar\fR to return error messages. .AP "CONST char" *varName in Name of global variable. .AP char *addr in Address of C variable that is to be linked to \fIvarName\fR. .AP int type in Type of C variable. Must be one of TCL_LINK_INT, TCL_LINK_DOUBLE, .VS 8.4 TCL_LINK_WIDE_INT, .VE 8.4 |
| ︙ | ︙ |
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.8.14.1 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 | .AP Tcl_EventDeleteProc *deleteProc in Procedure to invoke for each queued event in \fBTcl_DeleteEvents\fR. .AP int flags in What types of events to service. These flags are the same as those passed to \fBTcl_DoOneEvent\fR. .VS 8.1 .AP int mode in | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | .AP Tcl_EventDeleteProc *deleteProc in Procedure to invoke for each queued event in \fBTcl_DeleteEvents\fR. .AP int flags in What types of events to service. These flags are the same as those passed to \fBTcl_DoOneEvent\fR. .VS 8.1 .AP int mode in Indicates whether events should be serviced by \fBTcl_ServiceAll\fR. Must be one of \fBTCL_SERVICE_NONE\fR or \fBTCL_SERVICE_ALL\fR. .VE .BE .SH INTRODUCTION .PP The interfaces described here are used to customize the Tcl event |
| ︙ | ︙ | |||
462 463 464 465 466 467 468 | \fBTcl_CreateFileHandler\fR and \fBTcl_DeleteFileHandler\fR. To support a new platform or to integrate Tcl with an application-specific event loop, you must write new versions of these procedures. .PP \fBTcl_InitNotifier\fR initializes the notifier state and returns a handle to the notifier state. Tcl calls this | | | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 | \fBTcl_CreateFileHandler\fR and \fBTcl_DeleteFileHandler\fR. To support a new platform or to integrate Tcl with an application-specific event loop, you must write new versions of these procedures. .PP \fBTcl_InitNotifier\fR initializes the notifier state and returns a handle to the notifier state. Tcl calls this procedure when initializing a Tcl interpreter. Similarly, \fBTcl_FinalizeNotifier\fR shuts down the notifier, and is called by \fBTcl_Finalize\fR when shutting down a Tcl interpreter. .PP \fBTcl_WaitForEvent\fR is the lowest-level procedure in the notifier; it is responsible for waiting for an ``interesting'' event to occur or for a given time to elapse. Before \fBTcl_WaitForEvent\fR is invoked, each of the event sources' setup procedure will have been invoked. |
| ︙ | ︙ |
Changes to doc/ObjectType.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: ObjectType.3,v 1.3.14.3 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_ObjType 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_RegisterObjType, Tcl_GetObjType, Tcl_AppendAllObjTypes, Tcl_ConvertToType \- manipulate Tcl object types .SH SYNOPSIS |
| ︙ | ︙ | |||
130 131 132 133 134 135 136 137 138 139 140 141 142 143 | gets an up-to-date string representation for \fIobjPtr\fR by calling \fBTcl_GetStringFromObj\fR. It parses the string to obtain an integer and, if this succeeds, stores the integer in \fIobjPtr\fR's internal representation and sets \fIobjPtr\fR's \fItypePtr\fR member to point to the integer type's Tcl_ObjType structure. .PP The \fIupdateStringProc\fR member contains the address of a function called to create a valid string representation from an object's internal representation. .CS typedef void (Tcl_UpdateStringProc) (Tcl_Obj *\fIobjPtr\fR); .CE | > > | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | gets an up-to-date string representation for \fIobjPtr\fR by calling \fBTcl_GetStringFromObj\fR. It parses the string to obtain an integer and, if this succeeds, stores the integer in \fIobjPtr\fR's internal representation and sets \fIobjPtr\fR's \fItypePtr\fR member to point to the integer type's Tcl_ObjType structure. Do not release \fIobjPtr\fR's old internal representation unless you replace it with a new one or reset the \fItypePtr\fR member to NULL. .PP The \fIupdateStringProc\fR member contains the address of a function called to create a valid string representation from an object's internal representation. .CS typedef void (Tcl_UpdateStringProc) (Tcl_Obj *\fIobjPtr\fR); .CE |
| ︙ | ︙ |
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.13.4.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
321 322 323 324 325 326 327 | open for reading and writing. .PP \fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the names of the registered channels to the interpreter's result as a list object. \fBTcl_GetChannelNamesEx\fR will filter these names according to the \fIpattern\fR. If \fIpattern\fR is NULL, then it will not do any filtering. The return value is \fBTCL_OK\fR if no | | | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 | open for reading and writing. .PP \fBTcl_GetChannelNames\fR and \fBTcl_GetChannelNamesEx\fR write the names of the registered channels to the interpreter's result as a list object. \fBTcl_GetChannelNamesEx\fR will filter these names according to the \fIpattern\fR. If \fIpattern\fR is NULL, then it will not do any filtering. The return value is \fBTCL_OK\fR if no errors occurred writing to the result, otherwise it is \fBTCL_ERROR\fR, and the error message is left in the interpreter's result. .SH TCL_REGISTERCHANNEL .PP \fBTcl_RegisterChannel\fR adds a channel to the set of channels accessible in \fIinterp\fR. After this call, Tcl programs executing in that interpreter can refer to the channel in input or output operations using |
| ︙ | ︙ | |||
668 669 670 671 672 673 674 | the channel was created with \fBTcl_OpenFileChannel\fR, \fBTcl_OpenCommandChannel\fR, or \fBTcl_MakeFileChannel\fR. Other channel types may return a different type of handle on Windows platforms. On the Macintosh platform, the handle is a file reference number as returned from \fBHOpenDF\fR. .SH "SEE ALSO" | | | 668 669 670 671 672 673 674 675 676 677 678 679 | the channel was created with \fBTcl_OpenFileChannel\fR, \fBTcl_OpenCommandChannel\fR, or \fBTcl_MakeFileChannel\fR. Other channel types may return a different type of handle on Windows platforms. On the Macintosh platform, the handle is a file reference number as returned from \fBHOpenDF\fR. .SH "SEE ALSO" DString(3), fconfigure(n), filename(n), fopen(3), Tcl_CreateChannel(3) .SH KEYWORDS access point, blocking, buffered I/O, channel, channel driver, end of file, flush, input, nonblocking, output, read, seek, write |
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.7.4.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | .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. For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, determines the context for evaluating the script and also is used for error reporting; must not be NULL. | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | .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. For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, determines the context for evaluating the script and also is used for error reporting; must not be NULL. .AP "CONST char" *string in Pointer to first character in string to parse. .AP int numBytes in Number of bytes in \fIstring\fR, not including any terminating null character. If less than 0 then the script consists of all characters in \fIstring\fR up to the first null character. .AP int nested in Non-zero means that the script is part of a command substitution so an |
| ︙ | ︙ | |||
67 68 69 70 71 72 73 | .AP Tcl_Parse *parsePtr out Points to structure to fill in with information about the parsed command, expression, variable name, etc. Any previous information in this structure is ignored, unless \fIappend\fR is non-zero in a call to \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, or \fBTcl_ParseVarName\fR. | | | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 | .AP Tcl_Parse *parsePtr out Points to structure to fill in with information about the parsed command, expression, variable name, etc. Any previous information in this structure is ignored, unless \fIappend\fR is non-zero in a call to \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, or \fBTcl_ParseVarName\fR. .AP "CONST char" **termPtr out If not NULL, points to a location where \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVar\fR will store a pointer to the character just after the terminating character (the close-brace, the last character of the variable name, or the close-quote (respectively)) if the parse was successful. .AP Tcl_Parse *usedParsePtr in |
| ︙ | ︙ | |||
125 126 127 128 129 130 131 | If the braced string was parsed successfully, \fBTcl_ParseBraces\fR returns \fBTCL_OK\fR, fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the string (see below for details), and stores a pointer to the character just after the terminating \fB}\fR in the location given by \fI*termPtr\fR. | | | | | 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 | If the braced string was parsed successfully, \fBTcl_ParseBraces\fR returns \fBTCL_OK\fR, fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the string (see below for details), and stores a pointer to the character just after the terminating \fB}\fR in the location given by \fI*termPtr\fR. If an error occurs while parsing the string 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 or \fI*termPtr\fR. .PP \fBTcl_ParseQuotedString\fR parses a double-quoted string such as \fB"sum is [expr $a+$b]"\fR from the beginning of the argument \fIstring\fR. The first character of \fIstring\fR must be \fB"\fR. If the double-quoted string was parsed successfully, \fBTcl_ParseQuotedString\fR returns \fBTCL_OK\fR, fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the string (see below for details), and stores a pointer to the character just after the terminating \fB"\fR in the location given by \fI*termPtr\fR. If an error occurs while parsing the string 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 or \fI*termPtr\fR. .PP \fBTcl_ParseVarName\fR parses a Tcl variable reference such as \fB$abc\fR or \fB$x([expr $index + 1])\fR from the beginning of its \fIstring\fR argument. The first character of \fIstring\fR must be \fB$\fR. If a variable name was parsed successfully, \fBTcl_ParseVarName\fR returns \fBTCL_OK\fR and fills in the structure pointed to by \fIparsePtr\fR with information about the structure of the variable name (see below for details). If an error occurs while parsing the command then \fBTCL_ERROR\fR is returned, an error message is left in \fIinterp\fR's result (if \fIinterp\fR isn't NULL), and no information is left at \fI*parsePtr\fR. .PP \fBTcl_ParseVar\fR parse a Tcl variable reference such as \fB$abc\fR or \fB$x([expr $index + 1])\fR from the beginning of its \fIstring\fR argument. The first character of \fIstring\fR must be \fB$\fR. If the variable name is parsed successfully, \fBTcl_ParseVar\fR returns a |
| ︙ | ︙ | |||
341 342 343 344 345 346 347 | The \fInumComponents\fR field counts the total number of sub-tokens that make up the subexpression; this includes the sub-tokens for any nested \fBTCL_TOKEN_SUB_EXPR\fR tokens. .TP \fBTCL_TOKEN_OPERATOR\fR The token describes one operator of an expression such as \fB&&\fR or \fBhypot\fR. | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 | The \fInumComponents\fR field counts the total number of sub-tokens that make up the subexpression; this includes the sub-tokens for any nested \fBTCL_TOKEN_SUB_EXPR\fR tokens. .TP \fBTCL_TOKEN_OPERATOR\fR The token describes one operator of an expression such as \fB&&\fR or \fBhypot\fR. An \fBTCL_TOKEN_OPERATOR\fR token is always preceded by a \fBTCL_TOKEN_SUB_EXPR\fR token that describes the operator and its operands; the \fBTCL_TOKEN_SUB_EXPR\fR token's \fInumComponents\fR field can be used to determine the number of operands. A binary operator such as \fB*\fR is followed by two \fBTCL_TOKEN_SUB_EXPR\fR tokens that describe its operands. |
| ︙ | ︙ |
Changes to doc/RegExp.3.
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) 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. '\" | | | 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) 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. '\" '\" RCS: @(#) $Id: RegExp.3,v 1.9.2.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_RegExpMatch 3 8.1 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_RegExpMatch, Tcl_RegExpCompile, Tcl_RegExpExec, Tcl_RegExpRange, Tcl_GetRegExpFromObj, Tcl_RegExpMatchObj, Tcl_RegExpExecObj, Tcl_RegExpGetInfo \- Pattern matching with regular expressions .SH SYNOPSIS |
| ︙ | ︙ | |||
176 177 178 179 180 181 182 | direct control of Henry Spencer's regular expression library. For users that need to modify compilation and execution options directly, it is recommended that you use these interfaces instead of calling the internal regexp functions. These interfaces handle the details of UTF to Unicode translations as well as providing improved performance through caching in the pattern and string objects. .PP | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | direct control of Henry Spencer's regular expression library. For users that need to modify compilation and execution options directly, it is recommended that you use these interfaces instead of calling the internal regexp functions. These interfaces handle the details of UTF to Unicode translations as well as providing improved performance through caching in the pattern and string objects. .PP \fBTcl_GetRegExpFromObj\fR attempts to return a compiled regular expression from the \fIpatObj\fR. If the object does not already contain a compiled regular expression it will attempt to create one from the string in the object and assign it to the internal representation of the \fIpatObj\fR. The return value of this function is of type \fBTcl_RegExp\fR. The return value is a token for this compiled form, which can be used in subsequent calls to \fBTcl_RegExpExecObj\fR or \fBTcl_RegExpGetInfo\fR. If an error |
| ︙ | ︙ |
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.3.28.3 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | .sp int \fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR) .SH ARGUMENTS .AS Tcl_Interp *newValuePtr .AP Tcl_Interp *interp in Interpreter containing variable. | | | < < < | 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 | .sp int \fBTcl_UnsetVar2\fR(\fIinterp, name1, name2, flags\fR) .SH ARGUMENTS .AS Tcl_Interp *newValuePtr .AP Tcl_Interp *interp in Interpreter containing variable. .AP "CONST char" *name1 in Contains the name of an array variable (if \fIname2\fR is non-NULL) or (if \fIname2\fR is NULL) either the name of a scalar variable or a complete name including both variable name and index. May include \fB::\fR namespace qualifiers to specify a variable in a particular namespace. .AP "CONST char" *name2 in If non-NULL, gives name of element within array; in this case \fIname1\fR must refer to an array variable. .AP Tcl_Obj *newValuePtr in .VS 8.1 Points to a Tcl object containing the new value for the variable. .VE .AP int flags in OR-ed combination of bits providing additional information. See below for valid values. .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. |
| ︙ | ︙ |
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.9.8.3 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return an object's string representation. This is given by the returned byte pointer and (for \fBTcl_GetStringFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. If the object's UTF string representation is invalid (its byte pointer is NULL), the string representation is regenerated from the object's internal representation. The storage referenced by the returned byte pointer | | > > > > > > > > > > > | | 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 | \fBTcl_GetStringFromObj\fR and \fBTcl_GetString\fR return an object's string representation. This is given by the returned byte pointer and (for \fBTcl_GetStringFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. If the object's UTF string representation is invalid (its byte pointer is NULL), the string representation is regenerated from the object's internal representation. The storage referenced by the returned byte pointer is owned by the object manager. It is passed back as a writable pointer so that extension author creating their own \fBTcl_ObjType\fR will be able to modify the string representation within the \fBTcl_UpdateStringProc\fR of their \fBTcl_ObjType\fR. Except for that limited purpose, the pointer returned by \fBTcl_GetStringFromObj\fR or \fBTcl_GetString\fR should be treated as read-only. It is recommended that this pointer be assigned to a (CONST char *) variable. Even in the limited situations where writing to this pointer is acceptable, one should take care to respect the copy-on-write semantics required by \fBTcl_Obj\fR's, with appropriate calls to \fBTcl_IsShared\fR and \fBTcl_DuplicateObj\fR prior to any in-place modification of the string representation. The procedure \fBTcl_GetString\fR is used in the common case where the caller does not need the length of the string representation. .PP \fBTcl_GetUnicodeFromObj\fR and \fBTcl_GetUnicode\fR return an object's value as a Unicode string. This is given by the returned pointer and (for \fBTcl_GetUnicodeFromObj\fR) length, which is stored in \fIlengthPtr\fR if it is non-NULL. The storage referenced by the returned |
| ︙ | ︙ |
Changes to doc/Tcl_Main.3.
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) 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) 1994 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: Tcl_Main.3,v 1.4.6.3 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_Main 3 8.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_Main, Tcl_SetMainLoop \- main program and event loop definition for Tcl-based applications .SH SYNOPSIS |
| ︙ | ︙ | |||
100 101 102 103 104 105 106 | \fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; for more details on this procedure, see the documentation for \fBTcl_AppInit\fR. .PP When the \fIappInitProc\fR is finished, \fBTcl_Main\fR enters one of its two modes. If a startup script has been provided, \fBTcl_Main\fR attempts to evaluate it. Otherwise, interactive mode begins with examination of the variable \fItcl_rcFileName\fR in the master | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | \fIAppInitProc\fR is almost always a pointer to \fBTcl_AppInit\fR; for more details on this procedure, see the documentation for \fBTcl_AppInit\fR. .PP When the \fIappInitProc\fR is finished, \fBTcl_Main\fR enters one of its two modes. If a startup script has been provided, \fBTcl_Main\fR attempts to evaluate it. Otherwise, interactive mode begins with examination of the variable \fItcl_rcFileName\fR in the master interpreter. If that variable exists and holds the name of a readable file, the contents of that file are evaluated in the master interpreter. Then interactive operations begin, with prompts and command evaluation results written to the standard output channel, and commands read from the standard input channel and then evaluated. The prompts written to the standard output channel may be customized by defining the Tcl variables \fItcl_prompt1\fR and \fItcl_prompt2\fR as described in the documentation for \fBtclsh\fR. |
| ︙ | ︙ |
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.13.14.1 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | static and process-wide, yet each thread will end up associating a different block of storage with this key. .AP int *size in The size of the thread local storage block. This amount of data is allocated and initialized to zero the first time each thread calls \fBTcl_GetThreadData\fR. .AP Tcl_ThreadId *idPtr out | | | | | | 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 | static and process-wide, yet each thread will end up associating a different block of storage with this key. .AP int *size in The size of the thread local storage block. This amount of data is allocated and initialized to zero the first time each thread calls \fBTcl_GetThreadData\fR. .AP Tcl_ThreadId *idPtr out The referred storage will contain the id of the newly created thread as returned by the operating system. .AP Tcl_ThreadId id in Id of the thread waited upon. .AP Tcl_ThreadCreateProc threadProc in This procedure will act as the \fBmain()\fR of the newly created thread. The specified \fIclientData\fR will be its sole argument. .AP ClientData clientData in Arbitrary information. Passed as sole argument to the \fIthreadProc\fR. .AP int stackSize in The size of the stack given to the new thread. .AP int flags in Bitmask containing flags allowing the caller to modify behaviour of the new thread. .AP int *result out The referred storage is used to place the exit code of the thread waited upon into it. .BE .SH INTRODUCTION Beginning with the 8.1 release, the Tcl core is thread safe, which allows you to incorporate Tcl into multithreaded applications without customizing the Tcl core. To enable Tcl multithreading support, you must include the \fB--enable-threads\fR option to \fBconfigure\fR when you configure and compile your Tcl core. .PP An important constraint of the Tcl threads implementation is that \fIonly the thread that created a Tcl interpreter can use that interpreter\fR. In other words, multiple threads can not access the same Tcl interpreter. (However, as was the case in previous releases, a single thread can safely create and use multiple interpreters.) .PP .VS 8.3.1 Tcl does provide \fBTcl_CreateThread\fR for creating threads. The caller can determine the size of the stack given to the new thread and modify the behaviour through the supplied \fIflags\fR. The value \fBTCL_THREAD_STACK_DEFAULT\fR for the \fIstackSize\fR indicates that the default size as specified by the operating system is to be used for the new thread. As for the flags, currently are only the values \fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR defined. The first of them invokes the default behaviour with no specialties. Using the second value marks the new thread as \fIjoinable\fR. This means that another thread can wait for the such marked thread to exit and join it. .PP Restrictions: On some unix systems the pthread-library does not contain the functionality to specify the stacksize of a thread. The specified value for the stacksize is ignored on these systems. Both Windows and Macintosh currently do not support joinable threads. This |
| ︙ | ︙ |
Changes to doc/TraceCmd.3.
1 2 3 4 5 6 | '\" '\" Copyright (c) 2002 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 | '\" '\" Copyright (c) 2002 Donal K. Fellows '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" CVS: @(#) $Id: TraceCmd.3,v 1.4.2.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_TraceCommand 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command .SH SYNOPSIS |
| ︙ | ︙ | |||
102 103 104 105 106 107 108 | \fBTcl_CommandTraceInfo\fR may be used to retrieve information about traces set on a given command. The return value from \fBTcl_CommandTraceInfo\fR is the \fIclientData\fR associated with a particular trace. The trace must be on the command specified by the \fIinterp\fR, \fIcmdName\fR, and \fIflags\fR arguments (note that currently the flags are ignored; \fIflags\fR should be set to 0 for future | | | | 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 | \fBTcl_CommandTraceInfo\fR may be used to retrieve information about traces set on a given command. The return value from \fBTcl_CommandTraceInfo\fR is the \fIclientData\fR associated with a particular trace. The trace must be on the command specified by the \fIinterp\fR, \fIcmdName\fR, and \fIflags\fR arguments (note that currently the flags are ignored; \fIflags\fR should be set to 0 for future compatibility) and its trace procedure must the same as the \fIproc\fR argument. If the \fIprevClientData\fR argument is NULL then the return value corresponds to the first (most recently created) matching trace, or NULL if there are no matching traces. If the \fIprevClientData\fR argument isn't NULL, then it should be the return value from a previous call to \fBTcl_CommandTraceInfo\fR. In this case, the new return value will correspond to the next matching trace after the one whose \fIclientData\fR matches \fIprevClientData\fR, or NULL if no trace matches \fIprevClientData\fR or if there are no more matching traces after it. This mechanism makes it possible to step through all of the traces for a given command that have the same \fIproc\fR. .SH "CALLING COMMANDS DURING TRACES" .PP During rename traces, the command being renamed is visible with both names simultaneously, and the command still exists during delete traces (if TCL_INTERP_DESTROYED is not set). However, there is no mechanism for signaling that an error occurred in a trace procedure, so great care should be taken that errors do not get silently lost. .SH "MULTIPLE TRACES" .PP It is possible for multiple traces to exist on the same command. When this happens, all of the trace procedures will be invoked on each access, in order from most-recently-created to least-recently-created. |
| ︙ | ︙ |
Changes to doc/TraceVar.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: TraceVar.3,v 1.4.18.3 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_TraceVar 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable .SH SYNOPSIS |
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | .sp ClientData \fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR .SH ARGUMENTS .AS Tcl_VarTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing variable. | | < < < | | 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 | .sp ClientData \fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR .SH ARGUMENTS .AS Tcl_VarTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing variable. .AP "CONST char" *varName in Name of variable. May refer to a scalar variable, to an array variable with no index, or to an array variable with a parenthesized index. .AP int flags in OR-ed combination of the values TCL_TRACE_READS, TCL_TRACE_WRITES, TCL_TRACE_UNSETS, TCL_TRACE_ARRAY, TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, TCL_TRACE_RESULT_DYNAMIC and TCL_TRACE_RESULT_OBJECT. Not all flags are used by all procedures. See below for more information. .AP Tcl_VarTraceProc *proc in Procedure to invoke whenever one of the traced operations occurs. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP "CONST char" *name1 in Name of scalar or array variable (without array index). .AP "CONST char" *name2 in For a trace on an element of an array, gives the index of the element. For traces on scalar variables or on whole arrays, is NULL. .AP ClientData prevClientData in If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or |
| ︙ | ︙ |
Changes to doc/UpVar.3.
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: UpVar.3,v 1.4.2.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_UpVar 3 7.4 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_UpVar, Tcl_UpVar2 \- link one variable to another .SH SYNOPSIS |
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | .AS Tcl_VarTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing variables; also used for error reporting. .AP "CONST char" *frameName in Identifies the stack frame containing source variable. May have any of the forms accepted by the \fBupvar\fR command, such as \fB#0\fR or \fB1\fR. | | | | 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 | .AS Tcl_VarTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing variables; also used for error reporting. .AP "CONST char" *frameName in Identifies the stack frame containing source variable. May have any of the forms accepted by the \fBupvar\fR command, such as \fB#0\fR or \fB1\fR. .AP "CONST char" *sourceName in Name of source variable, in the frame given by \fIframeName\fR. May refer to a scalar variable or to an array variable with a parenthesized index. .AP "CONST char" *destName in Name of destination variable, which is to be linked to source variable so that references to \fIdestName\fR refer to the other variable. Must not currently exist except as an upvar-ed variable. .AP int flags in Either TCL_GLOBAL_ONLY or 0; if non-zero, then \fIdestName\fR is a global variable; otherwise it is a local to the current procedure (or global if no procedure is active). .AP "CONST char" *name1 in First part of source variable's name (scalar name, or name of array without array index). .AP "CONST char" *name2 in If source variable is an element of an array, gives the index of the element. For scalar source variables, is NULL. .BE |
| ︙ | ︙ |
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.9.12.3 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
151 152 153 154 155 156 157 | \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 | | | 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 | \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. |
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | .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 | | | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | .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. |
| ︙ | ︙ |
Changes to doc/WrongNumArgs.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: WrongNumArgs.3,v 1.3.18.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH Tcl_WrongNumArgs 3 8.0 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_WrongNumArgs \- generate standard error message for wrong number of arguments .SH SYNOPSIS |
| ︙ | ︙ | |||
59 60 61 62 63 64 65 | a subcommand. The command \fBTcl_GetIndexFromObj\fR will convert the abbreviated string object into an \fIindexObject\fR. If an error occurs in the parsing of the subcommand we would like to use the full subcommand name rather than the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any \fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand name in the error message instead of the abbreviated name that was | | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | a subcommand. The command \fBTcl_GetIndexFromObj\fR will convert the abbreviated string object into an \fIindexObject\fR. If an error occurs in the parsing of the subcommand we would like to use the full subcommand name rather than the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any \fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand name in the error message instead of the abbreviated name that was originally passed in. Using the above example, lets assume that \fIbar\fR is actually an abbreviation for \fIbarfly\fR and the object is now an indexObject because it was passed to \fBTcl_GetIndexFromObj\fR. In this case the error message would be: .CS wrong # args: should be "foo barfly fileName count" .CE .SH "SEE ALSO" Tcl_GetIndexFromObj .SH KEYWORDS command, error message, wrong number of arguments |
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.7.2.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
279 280 281 282 283 284 285 | .CE will return \fBdghi\fR. .RE .IP \fB@\fR 5 Moves the cursor to the absolute location in the output string specified by \fIcount\fR. Position 0 refers to the first byte in the output string. If \fIcount\fR refers to a position beyond the last | | | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 | .CE will return \fBdghi\fR. .RE .IP \fB@\fR 5 Moves the cursor to the absolute location in the output string specified by \fIcount\fR. Position 0 refers to the first byte in the output string. If \fIcount\fR refers to a position beyond the last byte stored so far, then null bytes will be placed in the uninitialized locations and the cursor will be placed at the specified location. If \fIcount\fR is \fB*\fR, then the cursor is moved to the current end of the output string. If \fIcount\fR is omitted, then an error will be generated. This type does not consume an argument. For example, .RS .CS \fBbinary format a5@2a1@*a3@10a1 abcde f ghi j\fR |
| ︙ | ︙ |
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 |
'\"
'\" 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.3.14.1 2002/08/20 20:25:24 das 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 spaces 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. For example, the command
.CS
\fBconcat a b {c d e} {f {g h}}\fR
.CE
will return
.CS
\fBa b c d e f {g h}\fR
.CE
as its result, and
.CS
\fBconcat " a b {c " d " e} f"\fR
.CE
will return
.CS
\fBa b {c d e} f\fR
.CE
as its result.
.PP
If no \fIarg\fRs are supplied, the result is an empty string.
.SH "SEE ALSO"
append(n), eval(n)
|
| ︙ | ︙ |
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 | '\" '\" 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.7.8.1 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ |
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 | '\" '\" 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.5.14.3 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
298 299 300 301 302 303 304 | .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. Returns the first random number from | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | .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. Returns the first random number 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 |
| ︙ | ︙ |
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.5.4.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | invoked. If \fInewValue\fR is \fBline\fR, then the I/O system will automatically flush output for the channel whenever a newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O system will flush automatically after every output operation. The default is for \fB\-buffering\fR to be set to \fBfull\fR except for channels that connect to terminal-like devices; for these channels the initial setting is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | invoked. If \fInewValue\fR is \fBline\fR, then the I/O system will automatically flush output for the channel whenever a newline character is output. If \fInewValue\fR is \fBnone\fR, the I/O system will flush automatically after every output operation. The default is for \fB\-buffering\fR to be set to \fBfull\fR except for channels that connect to terminal-like devices; for these channels the initial setting is \fBline\fR. Additionally, \fBstdin\fR and \fBstdout\fR are initially set to \fBline\fR, and \fBstderr\fR is set to \fBnone\fR. .TP \fB\-buffersize\fR \fInewSize\fR . \fINewvalue\fR must be an integer; its value is used to set the size of buffers, in bytes, subsequently allocated for this channel to store input or output. \fINewvalue\fR must be between ten and one million, allowing buffers of ten to one million bytes in size. |
| ︙ | ︙ | |||
227 228 229 230 231 232 233 | . (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. If \fItype\fR is \fBnone\fR then any handshake is switched off. \fBrtscts\fR activates hardware handshake. Hardware handshake signals | | | | 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 |
.
(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.
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
|
| ︙ | ︙ | |||
353 354 355 356 357 358 359 | 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 | | | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 | 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. .RE .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 |
| ︙ | ︙ |
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.8.8.3 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | accessed. If \fItime\fR is specified, it is an access time to set for the file. The time is measured in the standard POSIX fashion as seconds from a fixed starting time (often January 1, 1970). If the file doesn't exist or its access time cannot be queried or set then an error is generated. On Windows, FAT file systems do not support access time. .TP \fBfile attributes \fIname\fR | | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | accessed. If \fItime\fR is specified, it is an access time to set for the file. The time is measured in the standard POSIX fashion as seconds from a fixed starting time (often January 1, 1970). If the file doesn't exist or its access time cannot be queried or set then an error is generated. On Windows, FAT file systems do not support access time. .TP \fBfile attributes \fIname\fR .TP \fBfile attributes \fIname\fR ?\fBoption\fR? .TP \fBfile attributes \fIname\fR ?\fBoption value option value...\fR? .RS This subcommand returns or sets platform specific values associated with a file. The first form returns a list of the platform specific flags and their values. The second form returns the value for the specific option. The third form sets one or more of the values. The values are as follows: |
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | If \fIpattern\fR isn't specified, returns a list of names of all registered open channels in this interpreter. 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. .VE .TP \fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | If \fIpattern\fR isn't specified, returns a list of names of all registered open channels in this interpreter. 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. .VE .TP \fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR \fItarget\fR .TP \fBfile copy \fR?\fB\-force\fR? ?\fB\-\|\-\fR? \fIsource\fR ?\fIsource\fR ...? \fItargetDir\fR .RS The first form makes a copy of the file or directory \fIsource\fR under the pathname \fItarget\fR. If \fItarget\fR is an existing directory, then the second form is used. The second form makes a copy inside \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 |
| ︙ | ︙ | |||
186 187 188 189 190 191 192 193 194 195 196 197 198 199 | .CE returns \fB/foo/bar\fR. .PP Note that any of the names can contain separators, and that the result is always canonical for the current platform: \fB/\fR for Unix and Windows, and \fB:\fR for Macintosh. .RE .TP \fBfile lstat \fIname varName\fR . Same as \fBstat\fR option (see below) except uses the \fIlstat\fR kernel call instead of \fIstat\fR. This means that if \fIname\fR refers to a symbolic link the information returned in \fIvarName\fR is for the link rather than the file it refers to. On systems that | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | .CE returns \fB/foo/bar\fR. .PP Note that any of the names can contain separators, and that the result is always canonical for the current platform: \fB/\fR for Unix and Windows, and \fB:\fR for Macintosh. .RE .TP \fBfile link ?\fI-linktype\fR? \fIlinkName\fR ?\fItarget\fR? . 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. . If the user wishes to make a link of a specific type only, (and signal an error if for some reason that is not possible), then the optional \fI-linktype\fR argument should be given. Accepted values for \fI-linktype\fR are "-symbolic" and "-hard". . When creating links on filesystems that either do not support any links, or do not support the specific type requested, an error message will be returned. In particular Windows 95, 98 and ME do not support any links at present, but most Unix platforms support both symbolic and hard links (the latter for files only), MacOS supports symbolic links and Windows NT/2000/XP (on NTFS drives) support symbolic directory links and hard file links. .TP \fBfile lstat \fIname varName\fR . Same as \fBstat\fR option (see below) except uses the \fIlstat\fR kernel call instead of \fIstat\fR. This means that if \fIname\fR refers to a symbolic link the information returned in \fIvarName\fR is for the link rather than the file it refers to. On systems that |
| ︙ | ︙ | |||
222 223 224 225 226 227 228 | . 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 . | > | | | | | | | < | | | | | > | < < < < < | 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 | . 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 normalised 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 one 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 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 |
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | .TP \fBfile rootname \fIname\fR . Returns all of the characters in \fIname\fR up to but not including the last ``.'' character in the last component of name. If the last component of \fIname\fR doesn't contain a dot, then returns \fIname\fR. .TP | | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 | .TP \fBfile rootname \fIname\fR . Returns all of the characters in \fIname\fR up to but not including the last ``.'' character in the last component of name. If the last component of \fIname\fR doesn't contain a dot, then returns \fIname\fR. .TP \fBfile separator\fR ?\fIname\fR? . If no argument is given, returns the character which is used to separate path segments for native files on this platform. If a path is given, the filesystem responsible for that path is asked to return its separator character. If no file system accepts \fIname\fR, an error is generated. .TP |
| ︙ | ︙ | |||
318 319 320 321 322 323 324 | Returns a list whose elements are the path components in \fIname\fR. The first element of the list will have the same path type as \fIname\fR. All other elements will be relative. Path separators will be discarded unless they are needed ensure that an element is unambiguously relative. For example, under Unix .RS .CS | | | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 | Returns a list whose elements are the path components in \fIname\fR. The first element of the list will have the same path type as \fIname\fR. All other elements will be relative. Path separators will be discarded unless they are needed ensure that an element is unambiguously relative. For example, under Unix .RS .CS file split /foo/~bar/baz .CE returns \fB/\0\0foo\0\0./~bar\0\0baz\fR to ensure that later commands that use the third component do not attempt to perform tilde substitution. .RE .TP \fBfile stat \fIname varName\fR |
| ︙ | ︙ |
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.11.8.1 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
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
(e.g. \fBTEXT\fR). Items which are of the form \fI{macintosh type XXXX}\fR
or \fI{macintosh creator XXXX}\fR will match types or creators
| | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
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
(e.g. \fBTEXT\fR). Items which are of the form \fI{macintosh type XXXX}\fR
or \fI{macintosh creator XXXX}\fR will match types or creators
respectively. Unrecognized types, or specifications of multiple MacOS
types/creators will signal an error.
.PP
The two forms may be mixed, so \fB\-types {d f r w}\fR will find all
regular files OR directories that have both read AND write permissions.
The following are equivalent:
.RS
.CS
|
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | domain server. Otherwise, user account information is obtained from the local computer. On Windows 95 and 98, \fBglob\fR accepts patterns like ``.../'' and ``..../'' for successively higher up parent directories. . Since the backslash character has a special meaning to the glob command, glob patterns containing Windows style path separators need | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | domain server. Otherwise, user account information is obtained from the local computer. On Windows 95 and 98, \fBglob\fR accepts patterns like ``.../'' and ``..../'' for successively higher up parent directories. . Since the backslash character has a special meaning to the glob command, glob patterns containing Windows style path separators need special care. The pattern \fIC:\e\efoo\e\e*\fR is interpreted as \fIC:\efoo\e*\fR where \fI\ef\fR will match the single character \fIf\fR and \fI\e*\fR will match the single character \fI*\fR and will not be interpreted as a wildcard character. One solution to this problem is to use the Unix style forward slash as a path separator. Windows style paths can be converted to Unix style paths with the command \fBfile join $path\fR (or \fBfile normalize $path\fR in Tcl 8.4). .TP |
| ︙ | ︙ |
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 | '\" '\" 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.3.14.1 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | rather than local ones. Global variables are variables in the global namespace. For the duration of the current procedure (and only while executing in the current procedure), any reference to any of the \fIvarname\fRs will refer to the global variable by the same name. .PP | < < < | 24 25 26 27 28 29 30 31 32 33 34 35 36 | rather than local ones. Global variables are variables in the global namespace. For the duration of the current procedure (and only while executing in the current procedure), any reference to any of the \fIvarname\fRs will refer to the global variable by the same name. .PP .SH "SEE ALSO" namespace(n), upvar(n), variable(n) .SH KEYWORDS global, namespace, procedure, variable |
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 | '\" '\" 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. '\" '\" RCS: @(#) $Id: http.n,v 1.14.8.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH "http" n 2.4 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.4?\fR .sp \fB::http::config \fI?options?\fR .sp \fB::http::geturl \fIurl ?options?\fR .sp |
| ︙ | ︙ | |||
48 49 50 51 52 53 54 | .SH DESCRIPTION .PP 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 | | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | .SH DESCRIPTION .PP 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 \fBhttp::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. |
| ︙ | ︙ | |||
106 107 108 109 110 111 112 | 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\-useragent\fP \fIstring\fP The value of the User-Agent header in the HTTP request. The default | | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 | 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\-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 |
| ︙ | ︙ | |||
348 349 350 351 352 353 354 | For asynchronous \fB::http::geturl\fP calls, all of the above error situations apply, except that if there's any error while reading the HTTP reply headers or data, no exception is thrown. This is because after writing the HTTP headers, \fB::http::geturl\fP returns, and the rest of the HTTP transaction occurs in the background. The command callback can check if any error occurred during the read by calling | | | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 | For asynchronous \fB::http::geturl\fP calls, all of the above error situations apply, except that if there's any error while reading the HTTP reply headers or data, no exception is thrown. This is because after writing the HTTP headers, \fB::http::geturl\fP returns, and the rest of the HTTP transaction occurs in the background. The command callback can check if any error occurred during the read by calling \fB::http::status\fP to check the status and if its \fIerror\fP, calling \fB::http::error\fP to get the error message. .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 |
| ︙ | ︙ |
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.7.10.1 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
136 137 138 139 140 141 142 | To get a list of just the packages in the current interpreter, specify an empty string for the \fIinterp\fR argument. .TP \fBinfo locals \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the names of currently-defined local variables, including arguments to the current procedure, if any. | | | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | To get a list of just the packages in the current interpreter, specify an empty string for the \fIinterp\fR argument. .TP \fBinfo locals \fR?\fIpattern\fR? If \fIpattern\fR isn't specified, returns a list of all the names of currently-defined local variables, including arguments to the current procedure, if any. Variables defined with the \fBglobal\fR, \fBupvar\fR and \fBvariable\fR commands will not be returned. 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. .TP \fBinfo nameofexecutable\fR Returns the full path name of the binary file from which the application was invoked. If Tcl was unable to identify the file, then an empty |
| ︙ | ︙ |
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.7.8.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
173 174 175 176 177 178 179 | .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. | | | | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 | .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 HIDDEN COMMANDS, 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. |
| ︙ | ︙ | |||
322 323 324 325 326 327 328 | .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. | | | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 | .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 HIDDEN COMMANDS, 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 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. |
| ︙ | ︙ | |||
580 581 582 583 584 585 586 | hidden functionality in themselves or their descendants. .PP The set of hidden commands in an interpreter can be manipulated by a trusted interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp expose\fR command moves a hidden command to the set of exposed commands in the interpreter identified by \fIpath\fR, potentially renaming the command in the process. If an exposed command by | | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 | hidden functionality in themselves or their descendants. .PP The set of hidden commands in an interpreter can be manipulated by a trusted interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp expose\fR command moves a hidden command to the set of exposed commands in the interpreter identified by \fIpath\fR, potentially renaming the command in the process. If an exposed command by the targeted name already exists, the operation fails. Similarly, \fBinterp hide\fR moves an exposed command to the set of hidden commands in that interpreter. Safe interpreters are not allowed to move commands between the set of hidden and exposed commands, in either themselves or their descendants. .PP Currently, the names of hidden commands cannot contain namespace qualifiers, and you must first rename a command in a namespace to the |
| ︙ | ︙ |
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.6.14.1 2002/08/20 20:25:24 das 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. |
| ︙ | ︙ | |||
125 126 127 128 129 130 131 | .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 "SEE ALSO" | | | 125 126 127 128 129 130 131 132 133 134 135 | .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 "SEE ALSO" info sharedlibextension, Tcl_StaticPackage(3), safe(n) .SH KEYWORDS binary code, loading, safe interpreter, shared library |
Changes to doc/lsearch.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: lsearch.n,v 1.7.6.3 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
101 102 103 104 105 106 107 | and \fBend\-\fIinteger\fR refers to the last element in the list minus the specified integer offset. .VE 8.4 .PP If \fIoption\fR is omitted then it defaults to \fB\-glob\fR. If more than one of \fB\-exact\fR, \fB\-glob\fR, \fB\-regexp\fR, and \fB\-sorted\fR is specified, whichever option is specified last takes | | | < > | | | | 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 |
and \fBend\-\fIinteger\fR refers to the last element in the list minus
the specified integer offset.
.VE 8.4
.PP
If \fIoption\fR is omitted then it defaults to \fB\-glob\fR. If more
than one of \fB\-exact\fR, \fB\-glob\fR, \fB\-regexp\fR, and
\fB\-sorted\fR is specified, whichever option is specified last takes
precedence. If more than one of \fB\-ascii\fR, \fB\-dictionary\fR,
\fB\-integer\fR and \fB\-real\fR is specified, the option specified
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
lsearch {a b c d e} c => 2
lsearch -all {a b c a b c} c => 2 5
lsearch -inline {a20 b35 c47} b* => b35
lsearch -inline -not {a20 b35 c47} b* => a20
lsearch -all -inline -not {a20 b35 c47} b* => a20 c47
lsearch -all -not {a20 b35 c47} b* => 0 2
lsearch -start 3 {a b c a b c} c => 5
.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
|
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 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | '\" '\" 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.2.4.2 2002/08/20 20:25:24 das 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 .SH SYNOPSIS \fBlset \fIlist ?index...? newValue\fR .BE .SH DESCRIPTION .PP The \fBlset\fP command accepts a parameter, \fIlist\fP, which it interprets as the name of a variable containing a Tcl list. It also accepts zero or more \fIindices\fP into the list. The indices may be presented either consecutively on the command line, or grouped in a Tcl list and presented as a single argument. Finally, it accepts a new value for an element of \fIlist\fP. .PP If no indices are presented, the command takes the form: .CS lset list newValue .CE or .CS |
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | than or equal to zero. The integer appearing in each \fIindex\fR argument must be strictly less than the length of the corresponding list. In other words, the \fBlset\fR command cannot change the size of a list. If an index is outside the permitted range, an error is reported. .SH EXAMPLES In each of these examples, the initial value of \fIx\fP is: .CS | > | > > | < | 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 |
than or equal to zero. The integer appearing in each \fIindex\fR
argument must be strictly less than the length of the corresponding
list. In other words, the \fBlset\fR command cannot change the size
of a list. If an index is outside the permitted range, an error is reported.
.SH EXAMPLES
In each of these examples, the initial value of \fIx\fP is:
.CS
set x [list [list a b c] [list d e f] [list g h i]]
=> {a b c} {d e f} {g h i}
.CE
The indicated return value also becomes the new value of \fIx\fP.
.CS
lset x {j k l} => j k l
lset x {} {j k l} => j k l
lset x 0 j => j {d e f} {g h i}
lset x 2 j => {a b c} {d e f} j
lset x end j => {a b c} {d e f} j
lset x end-1 j => {a b c} j {d e f}
lset x 2 1 j => {a b c} {d e f} {g j i}
lset x {2 1} j => {a b c} {d e f} {g j i}
lset x {2 3} j
.CE
In the following examples, the initial value of \fIx\fP is:
.CS
set x [list [list [list a b] [list c d]] \e
[list [list e f] [list g h]]]
=> {{a b} {c d}} {{e f} {g h}}
.CE
The indicated return value also becomes the new value of \fIx\fP.
.CS
lset x 1 1 0 j => {{a b} {c d}} {{e f} {j h}}
lset x {1 1 0} j => {{a b} {c d}} {{e f} {j h}}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lindex(n), linsert(n), llength(n), lsearch(n),
lsort(n), lrange(n), lreplace(n)
.SH KEYWORDS
element, index, list, replace, set
|
Changes to doc/msgcat.n.
1 2 3 4 5 6 7 8 9 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" SCCS: @(#) msgcat.n '\" .so man.macros | | | | 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 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" '\" SCCS: @(#) msgcat.n '\" .so man.macros .TH "msgcat" n 1.3 msgcat "Tcl Bundled Packages" .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\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 |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | 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 \fB::msgcat::mc\fR is the main function used to localize an application. Instead of using an English string directly, an | | | | > | | | > > > | | > | > > > > | | | | | > | | | | | > | | | > > > > > > > > > > > > | | | < > | | | 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 |
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
\fB::msgcat::mc\fR is the main function used to localize an
application. Instead of using an English string directly, an
application can pass the English string through \fB::msgcat::mc\fR and
use the result. If an application is written for a single language in
this fashion, then it is easy to add support for additional languages
later simply by defining new message catalog entries.
.TP
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
Given several source strings, \fB::msgcat::mcmax\fR returns the length
of the longest translated string. This is useful when designing
localized GUIs, which may require that all buttons, for example, be a
fixed width (which will be the width of the widest button).
.TP
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR
is omitted, the current locale is returned, otherwise the current locale
is set to \fInewLocale\fR. msgcat stores and compares the locale in a
case-insensitive manner, and returns locales in lowercase.
The initial locale is determined by the locale specified in
the user's environment. See \fBLOCALE SPECIFICATION\fR
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 \fBmsgcat::mclocale\fR, and
cannot be set independently. For example, if the
current locale is en_US_funky, then \fBmsgcat::mcpreferences\fR
returns {en_US_funky en_US en}.
.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 non-Latin 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?} \fBmsgcat::mcmset\fR can be significantly
faster than multiple invocations of \fBmsgcat::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
\fBmsgcat::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::unknown\fR is
called.
.SH "NAMESPACES AND MESSAGE CATALOGS"
.PP
Strings stored in the message catalog are stored relative
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 | .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 | | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 |
.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
mcset en m1 ":: message1"
mcset en m2 ":: message2"
mcset en m3 ":: message3"
namespace eval ::foo {
mcset en m2 "::foo message2"
mcset en m3 "::foo message3"
|
| ︙ | ︙ | |||
203 204 205 206 207 208 209 | .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] | | | | | | > > > > | > | | 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 |
.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]
The message file name is a msgcat locale specifier (all lowercase)
followed by ``.msg''. For example:
.CS
es.msg -- spanish
en_gb.msg -- United Kingdom English
.CE
.IP [3]
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 {
::msgcat::mcset 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
::msgcat::mcload [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.
.CS
|
| ︙ | ︙ |
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.12.14.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
142 143 144 145 146 147 148 | the PORTABILITY ISSUES section. .PP The \fBfconfigure\fR command can be used to query and set additional configuration options specific to serial ports. .VE .SH "PORTABILITY ISSUES" | < | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 | the PORTABILITY ISSUES section. .PP The \fBfconfigure\fR command can be used to query and set additional configuration options specific to serial ports. .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 |
| ︙ | ︙ | |||
230 231 232 233 234 235 236 | .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 "SEE ALSO" file(n), close(n), filename(n), fconfigure(n), gets(n), read(n), | | | 229 230 231 232 233 234 235 236 237 238 239 240 | .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 "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/packagens.n.
1 2 3 4 | '\" '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" | | | 1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1998-2000 by Scriptics Corporation. '\" All rights reserved. '\" '\" RCS: @(#) $Id: packagens.n,v 1.3.14.1 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH pkg::create n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pkg::create \- Construct an appropriate \fBpackage ifneeded\fR |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | .TP \fB\-source\fR\0\fIfilespec\fR This parameter is similar to the \fB\-load\fR parameter, except that it specifies a Tcl library that must be loaded with the \fBsource\fR command. Any number of \fB\-source\fR parameters may be specified. .PP | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | .TP \fB\-source\fR\0\fIfilespec\fR This parameter is similar to the \fB\-load\fR parameter, except that it specifies a Tcl library that must be loaded with the \fBsource\fR command. Any number of \fB\-source\fR parameters may be specified. .PP At least one \fB\-load\fR or \fB\-source\fR parameter must be given. .SH "SEE ALSO" package(n) .SH KEYWORDS auto-load, index, package, version |
Changes to doc/pkgMkIndex.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: pkgMkIndex.n,v 1.12.8.1 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH pkg_mkIndex n 8.3 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME pkg_mkIndex \- Build an index for automatic loading of packages |
| ︙ | ︙ | |||
201 202 203 204 205 206 207 | these calls are handled by a stub \fBunknown\fP command. However, if scripts make variable references to other package's variables in global code, these will cause errors. That is also bad coding style. .PP If binary files have dependencies on other packages, things can become tricky because it is not possible to stub out | | | 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 | these calls are handled by a stub \fBunknown\fP command. However, if scripts make variable references to other package's variables in global code, these will cause errors. That is also bad coding style. .PP If binary files have dependencies on other packages, things can become tricky because it is not possible to stub out C-level APIs such as \fBTcl_PkgRequire\fP API when loading a binary file. For example, suppose the BLT package requires Tk, and expresses this with a call to \fBTcl_PkgRequire\fP in its \fBBlt_Init\fP routine. To support this, you must run \fBpkg_mkIndex\fR in an interpreter that has Tk loaded. You can achieve this with the \fB\-load \fIpkgPat\fR option. If you specify this option, \fBpkg_mkIndex\fR will load any packages listed by |
| ︙ | ︙ |
Changes to doc/registry.n.
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 15 16 17 | '\" '\" 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: registry.n,v 1.4.28.1 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH registry n 1.0 registry "Tcl Bundled Packages" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME registry \- Manipulate the Windows registry .SH SYNOPSIS .sp \fBpackage require registry 1.0\fR |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | are: .TP \fBregistry delete \fIkeyName\fR ?\fIvalueName\fR? . If the optional \fIvalueName\fR argument is present, the specified value under \fIkeyName\fR will be deleted from the registry. If the optional \fIvalueName\fR is omitted, the specified key and any subkeys | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | are: .TP \fBregistry delete \fIkeyName\fR ?\fIvalueName\fR? . If the optional \fIvalueName\fR argument is present, the specified value under \fIkeyName\fR will be deleted from the registry. If the optional \fIvalueName\fR is omitted, the specified key and any subkeys or values beneath it in the registry hierarchy will be deleted. If the key could not be deleted then an error is generated. If the key did not exist, the command has no effect. .TP \fBregistry get \fIkeyName valueName\fR . Returns the data associated with the value \fIvalueName\fR under the key \fIkeyName\fR. If either the key or the value does not exist, then an |
| ︙ | ︙ |
Changes to doc/resource.n.
1 2 3 4 5 | '\" '\" 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 | '\" '\" 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: resource.n,v 1.6.14.1 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH resource n 8.0 Tcl "Tcl Built-In Commands" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME resource \- Manipulate Macintosh resources |
| ︙ | ︙ | |||
117 118 119 120 121 122 123 | If \fB-name\fR is specified the resource will be named \fIresourceName\fR, otherwise it will have the empty string as the name. .TP \fB\-file\fR \fIresourceRef\fR If the \fB-file\fR option is specified then the resource will be written in the file pointed to by \fIresourceRef\fR, otherwise the | | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | If \fB-name\fR is specified the resource will be named \fIresourceName\fR, otherwise it will have the empty string as the name. .TP \fB\-file\fR \fIresourceRef\fR If the \fB-file\fR option is specified then the resource will be written in the file pointed to by \fIresourceRef\fR, otherwise the most recently open resource will be used. .TP \fB\-force\fR If the target resource already exists, then by default Tcl will not overwrite it, but raise an error instead. Use the -force flag to force overwriting the extant resource. .RE |
| ︙ | ︙ |
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.3.28.1 2002/08/20 20:25:24 das 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. |
| ︙ | ︙ | |||
242 243 244 245 246 247 248 | The \fBfile\fR alias provides access to a safe subset of the subcommands of the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR, \fBextension\fR, \fBroot\fR, \fBtail\fR, \fBpathname\fR and \fBsplit\fR subcommands. For more details on what these subcommands do see the manual page for the \fBfile\fR command. .TP \fBencoding\fR ?\fIsubCmd args...\fR? | | | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 | The \fBfile\fR alias provides access to a safe subset of the subcommands of the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR, \fBextension\fR, \fBroot\fR, \fBtail\fR, \fBpathname\fR and \fBsplit\fR subcommands. For more details on what these subcommands do see the manual page for the \fBfile\fR command. .TP \fBencoding\fR ?\fIsubCmd args...\fR? The \fBencoding\fR alias provides access to a safe subset of the subcommands of the \fBencoding\fR command; it disallows setting of the system encoding, but allows all other subcommands including \fBsystem\fR to check the current encoding. .TP \fBexit\fR The calling interpreter is deleted and its computation is stopped, but the Tcl process in which this interpreter exists is not terminated. |
| ︙ | ︙ |
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.7.14.2 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
173 174 175 176 177 178 179 | character between \fIa\fR and \fIb\fR (inclusive) will be excluded from the set. If the first or last character between the brackets is a \fB\-\fR, then it is treated as part of \fIchars\fR rather than indicating a range. .TP 10 \fBn\fR No input is consumed from the input string. Instead, the total number | | | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 | character between \fIa\fR and \fIb\fR (inclusive) will be excluded from the set. If the first or last character between the brackets is a \fB\-\fR, then it is treated as part of \fIchars\fR rather than indicating a range. .TP 10 \fBn\fR No input is consumed from the input string. Instead, the total number of characters scanned from the input string so far is stored in the variable. .LP The number of characters read from the input for a conversion is the largest number that makes sense for that particular conversion (e.g. 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 |
| ︙ | ︙ |
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 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 |
'\"
'\" 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.14.14.2 2002/08/20 20:25:24 das 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
.SH SYNOPSIS
\fBstring \fIoption arg \fR?\fIarg ...?\fR
.BE
.SH DESCRIPTION
.PP
Performs one of several string operations, depending on \fIoption\fR.
The legal \fIoption\fRs (which may be abbreviated) are:
.TP
\fBstring bytelength \fIstring\fR
Returns a decimal string giving the number of bytes used to represent
\fIstring\fR in memory. Because UTF\-8 uses one to three bytes to
represent Unicode characters, the byte length will not be the same as
the character length in general. The cases where a script cares about
the byte length are rare. In almost all cases, you should use the
\fBstring length\fR operation (including determining the length of a
Tcl ByteArray object). Refer to the \fBTcl_NumUtfChars\fR manual
entry for more details on the UTF\-8 representation.
.TP
\fBstring compare\fR ?\fB\-nocase\fR? ?\fB\-length int\fR? \fIstring1 string2\fR
Perform a character-by-character comparison of strings \fIstring1\fR
and \fIstring2\fR. Returns \-1, 0, or 1, depending on whether
\fIstring1\fR is lexicographically less than, equal to, or greater
than \fIstring2\fR. If \fB\-length\fR is specified, then only the
first \fIlength\fR characters are used in the comparison. If
\fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is
specified, then the strings are compared in a case-insensitive manner.
.TP
\fBstring equal\fR ?\fB\-nocase\fR? ?\fB-length int\fR? \fIstring1 string2\fR
Perform a character-by-character comparison of strings \fIstring1\fR
and \fIstring2\fR. Returns 1 if \fIstring1\fR and \fIstring2\fR are
identical, or 0 when not. If \fB\-length\fR is specified, then only
the first \fIlength\fR characters are used in the comparison. If
\fB\-length\fR is negative, it is ignored. If \fB\-nocase\fR is
specified, then the strings are compared in a case-insensitive manner.
.TP
\fBstring first \fIstring1 string2\fR ?\fIstartIndex\fR?
Search \fIstring2\fR for a sequence of characters that exactly match
the characters in \fIstring1\fR. If found, return the index of the
first character in the first such match within \fIstring2\fR. If not
found, return \-1. If \fIstartIndex\fR is specified (in any of the
forms accepted by the \fBindex\fR method), then the search is
constrained to start with the character in \fIstring2\fR specified by
the index. For example,
.RS
.CS
\fBstring first a 0a23456789abcdef 5\fR
.CE
will return \fB10\fR, but
.CS
\fBstring first a 0123456789abcdef 11\fR
.CE
will return \fB\-1\fR.
.RE
.TP
\fBstring index \fIstring charIndex\fR
Returns the \fIcharIndex\fR'th character of the \fIstring\fR argument.
A \fIcharIndex\fR of 0 corresponds to the first character of the
string. \fIcharIndex\fR may be specified as follows:
.RS
.IP \fIinteger\fR 10
The char specified at this integral index.
.IP \fBend\fR 10
The last char of the string.
.IP \fBend\-\fIinteger\fR 10
The last char of the string minus the specified integer offset
(e.g. \fBend\-1\fR would refer to the "c" in "abcd").
.PP
If \fIcharIndex\fR is less than 0 or greater than or equal to the
length of the string then an empty string is returned.
.RE
.TP
\fBstring is \fIclass\fR ?\fB\-strict\fR? ?\fB\-failindex \fIvarname\fR? \fIstring\fR
Returns 1 if \fIstring\fR is a valid member of the specified character
class, otherwise returns 0. If \fB\-strict\fR is specified, then an
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 10
Any Unicode alphabet or digit character.
.IP \fBalpha\fR 10
Any Unicode alphabet character.
.IP \fBascii\fR 10
Any character with a value less than \\u0080 (those that are in the
7\-bit ascii range).
.IP \fBboolean\fR 10
Any of the forms allowed to \fBTcl_GetBoolean\fR.
.IP \fBcontrol\fR 10
Any Unicode control character.
.IP \fBdigit\fR 10
Any Unicode digit character. Note that this includes characters
outside of the [0\-9] range.
.IP \fBdouble\fR 10
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 10
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
false.
.IP \fBgraph\fR 10
Any Unicode printing character, except space.
.IP \fBinteger\fR 10
Any of the valid forms for an 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 10
Any Unicode lower case alphabet character.
.IP \fBprint\fR 10
Any Unicode printing character, including space.
.IP \fBpunct\fR 10
Any Unicode punctuation character.
.IP \fBspace\fR 10
Any Unicode space character.
.IP \fBtrue\fR 10
Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
true.
.IP \fBupper\fR 10
Any upper case alphabet character in the Unicode character set.
.IP \fBwordchar\fR 10
Any Unicode word character. That is any alphanumeric character, and
any Unicode connector punctuation characters (e.g. underscore).
.IP \fBxdigit\fR 10
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
\fBstring last \fIstring1 string2\fR ?\fIlastIndex\fR?
Search \fIstring2\fR for a sequence of characters that exactly match
the characters in \fIstring1\fR. If found, return the index of the
first character in the last such match within \fIstring2\fR. If there
is no match, then return \-1. If \fIlastIndex\fR is specified (in any
of the forms accepted by the \fBindex\fR method), then only the
characters in \fIstring2\fR at or before the specified \fIlastIndex\fR
will be considered by the search. For example,
.RS
.CS
\fBstring last a 0a23456789abcdef 15\fR
.CE
will return \fB10\fR, but
.CS
\fBstring last a 0a23456789abcdef 9\fR
.CE
will return \fB1\fR.
.RE
.TP
\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? \fIcharMap string\fR
Replaces characters in \fIstring\fR based on the key-value pairs in
\fIcharMap\fR. \fIcharMap\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.
.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
following special sequences may appear in \fIpattern\fR:
.RS
.IP \fB*\fR 10
Matches any sequence of characters in \fIstring\fR, including a null
string.
.IP \fB?\fR 10
Matches any single character in \fIstring\fR.
.IP \fB[\fIchars\fB]\fR 10
Matches any character in the set given by \fIchars\fR. If a sequence
of the form \fIx\fB\-\fIy\fR appears in \fIchars\fR, then any
character between \fIx\fR and \fIy\fR, inclusive, will match. When
used with \fB\-nocase\fR, the end points of the range are converted to
lower case first. Whereas {[A\-z]} matches '_' when matching
case-sensitively ('_' falls between the 'Z' and 'a'), with
\fB\-nocase\fR this is considered like {[A\-Za\-z]} (and probably what
was meant in the first place).
.IP \fB\e\fIx\fR 10
Matches the single character \fIx\fR. This provides a way of avoiding
the special interpretation of the characters \fB*?[]\e\fR in
\fIpattern\fR.
.RE
.TP
\fBstring range \fIstring first last\fR
Returns a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
character whose index is \fIlast\fR. An index of 0 refers to the first
character of the string. \fIfirst\fR and \fIlast\fR may be specified
as for the \fBindex\fR method. If \fIfirst\fR is less than zero then
it is treated as if it were zero, and if \fIlast\fR is greater than or
equal to the length of the string then it is treated as if it were
\fBend\fR. If \fIfirst\fR is greater than \fIlast\fR then an empty
string is returned.
.TP
\fBstring repeat \fIstring count\fR
Returns \fIstring\fR repeated \fIcount\fR number of times.
.TP
\fBstring replace \fIstring first last\fR ?\fInewstring\fR?
Removes a range of consecutive characters from \fIstring\fR, starting
with the character whose index is \fIfirst\fR and ending with the
character whose index is \fIlast\fR. An index of 0 refers to the
first character of the string. \fIFirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method. If \fInewstring\fR is
specified, then it is placed in the removed character range. If
\fIfirst\fR is less than zero then it is treated as if it were zero,
and if \fIlast\fR is greater than or equal to the length of the string
then it is treated as if it were \fBend\fR. If \fIfirst\fR is greater
than \fIlast\fR or the length of the initial string, or \fIlast\fR is
less than 0, then the initial string is returned untouched.
.TP
\fBstring tolower \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that all upper (or title)
case letters have been converted to lower case. If \fIfirst\fR is
specified, it refers to the first char index in the string to start
modifying. If \fIlast\fR is specified, it refers to the char index in
the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring totitle \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that the first character
in \fIstring\fR is converted to its Unicode title case variant (or
upper case if there is no title case variant) and the rest of the
string is converted to lower case. If \fIfirst\fR is specified, it
refers to the first char index in the string to start modifying. If
\fIlast\fR is specified, it refers to the char index in the string to
stop at (inclusive). \fIfirst\fR and \fIlast\fR may be specified as
for the \fBindex\fR method.
.TP
\fBstring toupper \fIstring\fR ?\fIfirst\fR? ?\fIlast\fR?
Returns a value equal to \fIstring\fR except that all lower (or title)
case letters have been converted to upper case. If \fIfirst\fR is
specified, it refers to the first char index in the string to start
modifying. If \fIlast\fR is specified, it refers to the char index in
the string to stop at (inclusive). \fIfirst\fR and \fIlast\fR may be
specified as for the \fBindex\fR method.
.TP
\fBstring trim \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading or
trailing characters from the set given by \fIchars\fR are removed. If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimleft \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any leading
characters from the set given by \fIchars\fR are removed. If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring trimright \fIstring\fR ?\fIchars\fR?
Returns a value equal to \fIstring\fR except that any trailing
characters from the set given by \fIchars\fR are removed. If
\fIchars\fR is not specified then white space is removed (spaces,
tabs, newlines, and carriage returns).
.TP
\fBstring wordend \fIstring charIndex\fR
Returns the index of the character just after the last one 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.
.TP
\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
|
Changes to doc/tclsh.1.
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: tclsh.1,v 1.5.6.2 2002/08/20 20:25:24 das Exp $ '\" .so man.macros .TH tclsh 1 "" Tcl "Tcl Applications" .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME tclsh \- Simple shell containing Tcl interpreter |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | incomplete commands. .SH "STANDARD CHANNELS" .PP See \fBTcl_StandardChannels\fR for more explanations. .SH "SEE ALSO" | | | 124 125 126 127 128 129 130 131 132 133 134 | incomplete commands. .SH "STANDARD CHANNELS" .PP See \fBTcl_StandardChannels\fR for more explanations. .SH "SEE ALSO" fconfigure(n), tclvars(n) .SH KEYWORDS argument, interpreter, prompt, script file, shell |
Changes to doc/tcltest.n.
1 2 3 4 5 6 7 8 9 | '\" '\" 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 '\" '\" 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 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 |
'\"
'\" 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.11.14.3 2002/08/20 20:25:24 das Exp $
'\"
.so man.macros
.TH "tcltest" n 2.1 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.1?\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
.VS 2.1
\fBtcltest::configure\fR
\fBtcltest::configure \fIoption\fR
\fBtcltest::configure \fIoption value ?option value ...?\fR
\fBtcltest::customMatch \fImode command\fR
.VE
\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
\fBtcltest::limitConstraints \fI?boolean?\fR
\fBtcltest::loadFile \fI?filename?\fR
\fBtcltest::loadScript \fI?script?\fR
\fBtcltest::match \fI?patternList?\fR
\fBtcltest::matchDirectories \fI?patternList?\fR
\fBtcltest::matchFiles \fI?patternList?\fR
\fBtcltest::outputFile \fI?filename?\fR
\fBtcltest::preserveCore \fI?level?\fR
\fBtcltest::singleProcess \fI?boolean?\fR
\fBtcltest::skip \fI?patternList?\fR
\fBtcltest::skipDirectories \fI?patternList?\fR
\fBtcltest::skipFiles \fI?patternList?\fR
\fBtcltest::temporaryDirectory \fI?directory?\fR
\fBtcltest::testsDirectory \fI?directory?\fR
\fBtcltest::verbose \fI?level?\fR
.sp
\fBtcltest::test \fIname description optionList\fR
\fBtcltest::bytestring \fIstring\fR
\fBtcltest::normalizeMsg \fImsg\fR
\fBtcltest::normalizePath \fIpathVar\fR
\fBtcltest::workingDirectory \fI?dir?\fR
.fi
.BE
.SH DESCRIPTION
.PP
The \fBtcltest\fR package provides several utility commands useful
in the construction of test suites for code instrumented to be
run by evaluation of Tcl commands. Notably the built-in commands
of the Tcl library itself are tested by a test suite using the
tcltest package.
.PP
All the commands provided by the \fBtcltest\fR package are defined
in and exported from the \fB::tcltest\fR namespace, as indicated in
the \fBSYNOPSIS\fR above. In the following sections, all commands
will be described by their simple names, in the interest of brevity.
.PP
The central command of \fBtcltest\fR is [\fBtest\fR] that defines
and runs a test. Testing with [\fBtest\fR] involves evaluation
of a Tcl script and comparing the result to an expected result, as
configured and controlled by a number of options. Several other
commands provided by \fBtcltest\fR govern the configuration of
[\fBtest\fR] and the collection of many [\fBtest\fR] commands into
test suites.
.PP
See \fBCREATING TEST SUITES WITH TCLTEST\fR below for an extended example
of how to use the commands of \fBtcltest\fR to produce test suites
for your Tcl-enabled code.
.SH COMMANDS
.TP
\fBtest\fR \fIname description ?option value ...?\fR
Defines and possibly runs a test with the name \fIname\fR and
description \fIdescription\fR. The name and description of a test
are used in messages reported by [\fBtest\fR] during the
test, as configured by the options of \fBtcltest\fR. The
remaining \fIoption value\fR arguments to [\fBtest\fR]
define the test, including the scripts to run, the conditions
under which to run them, the expected result, and the means
by which the expected and actual results should be compared.
See \fBTESTS\fR below for a complete description of the valid
options and how they define a test. The [\fBtest\fR] command
returns an empty string.
.TP
\fBtest\fR \fIname description ?constraints? body result\fR
This form of [\fBtest\fR] is provided to support test suites written
for version 1 of the \fBtcltest\fR package, and also a simpler
interface for a common usage. It is the same as
[\fBtest\fR \fIname description\fB -constraints \fIconstraints\fB -body
\fIbody\fB -result \fIresult\fR]. All other options to [\fBtest\fR]
take their default values. When \fIconstraints\fR is omitted, this
form of [\fBtest\fR] can be distinguished from the first because
all \fIoption\fRs begin with ``-''.
.TP
\fBloadTestedCommands\fR
Evaluates in the caller's context the script specified by
[\fBconfigure -load\fR] or [\fBconfigure -loadfile\fR].
Returns the result of that script evaluation, including any error
raised by the script. Use this command and the related
configuration options to provide the commands to be tested to
the interpreter running the test suite.
.TP
\fBmakeFile\fR \fIcontents name ?directory?\fR
Creates a file named \fIname\fR relative to
directory \fIdirectory\fR and write \fIcontents\fR
to that file using the encoding [\fBencoding system\fR].
If \fIcontents\fR does not end with a newline, a newline
will be appended so that the file named \fIname\fR
does end with a newline. Because the system encoding is used,
this command is only suitable for making text files.
The file will be removed by the next evaluation
of [\fBcleanupTests\fR], unless it is removed by
[\fBremoveFile\fR] first. The default value of
\fIdirectory\fR is the directory [\fBconfigure -tmpdir\fR].
Returns the full path of the file created. Use this command
to create any text file required by a test with contents as needed.
.TP
\fBremoveFile\fR \fIname ?directory?\fR
Forces the file referenced by \fIname\fR to be removed. This file name
should be relative to \fIdirectory\fR. The default value of
\fIdirectory\fR is the directory [\fBconfigure -tmpdir\fR].
Returns an empty string. Use this command to delete files
created by [\fBmakeFile\fR].
.TP
\fBmakeDirectory\fR \fIname ?directory?\fR
Creates a directory named \fIname\fR relative to directory \fIdirectory\fR.
The directory will be removed by the next evaluation of [\fBcleanupTests\fR],
unless it is removed by [\fBremoveDirectory\fR] first.
The default value of \fIdirectory\fR is the directory
[\fBconfigure -tmpdir\fR].
Returns the full path of the directory created. Use this command
to create any directories that are required to exist by a test.
.TP
\fBremoveDirectory\fR \fIname ?directory?\fR
Forces the directory referenced by \fIname\fR to be removed. This
directory should be relative to \fIdirectory\fR.
The default value of \fIdirectory\fR is the directory
[\fBconfigure -tmpdir\fR].
Returns an empty string. Use this command to delete any directories
created by [\fBmakeDirectory\fR].
.TP
\fBviewFile\fR \fIfile ?directory?\fR
Returns the contents of \fIfile\fR, except for any
final newline, just as [\fBread -nonewline\fR] would return.
This file name should be relative to \fIdirectory\fR.
The default value of \fIdirectory\fR is the directory
[\fBconfigure -tmpdir\fR]. Use this command
as a convenient way to turn the contents of a file generated
by a test into the result of that test for matching against
an expected result. The contents of the file are read using
the system encoding, so its usefulness is limited to text
files.
.TP
\fBcleanupTests\fR
Intended to clean up and summarize after several tests have been
run. Typically called once per test file, at the end of the file
after all tests have been completed. For best effectiveness, be
sure that the [\fBcleanupTests\fR] is evaluated even if an error
occurs earlier in the test file evaluation.
.sp
Prints statistics about the tests run and removes files that were
created by [\fBmakeDirectory\fR] and [\fBmakeFile\fR] since the
last [\fBcleanupTests\fR]. Names of files and directories
in the directory [\fBconfigure -tmpdir\fR] created since
the last [\fBcleanupTests\fR], but not created by
[\fBmakeFile\fR] or [\fBmakeDirectory\fR] are printed
to [\fBoutputChannel\fR]. This command also restores the original
shell environment, as described by the ::env
array. Returns an empty string.
.TP
\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"
.VS
.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
Returns the current value of the supported configurable option \fIoption\fR.
Raises an error if \fIoption\fR is not a supported configurable option.
.TP
\fBconfigure \fIoption value ?option value ...?\fR
Sets the value of each configurable option \fIoption\fR to the
corresponding value \fIvalue\fR, in order. Raises an error if
an \fIoption\fR is not a supported configurable option, or if
\fIvalue\fR is not a valid value for the corresponding \fIoption\fR,
or if a \fIvalue\fR is not provided. When an error is raised, the
operation of [\fBconfigure\fR] is halted, and subsequent \fIoption value\fR
arguments are not processed.
.sp
If the environment variable \fB::env(TCLTEST_OPTIONS)\fR exists when
the \fBtcltest\fR package is loaded (by [\fBpackage require tcltest\fR])
then its value is taken as a list of arguments to pass to [\fBconfigure\fR].
This allows the default values of the configuration options to be
set by the environment.
.TP
\fBcustomMatch \fImode script\fR
Registers \fImode\fR as a new legal value of the \fB-match\fR option
to [\fBtest\fR]. When the \fB-match \fImode\fR option is
passed to [\fBtest\fR], the script \fIscript\fR will be evaluated
to compare the actual result of evaluating the body of the test
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.
.VE
.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
[\fBrunAllTests\fR] to run each test file when
[\fBconfigure -singleproc\fR] is false.
The default value for [\fBinterpreter\fR] is the name of the
currently running program as returned by [\fBinfo nameofexecutable\fR].
.TP
\fBoutputChannel\fR \fI?channelID?\fR
Sets or returns the output channel ID. This defaults to stdout.
Any test that prints test related output should send
that output to [\fBoutputChannel\fR] rather than letting
that output default to stdout.
.TP
\fBerrorChannel\fR \fI?channelID?\fR
Sets or returns the error channel ID. This defaults to stderr.
Any test that prints error messages should send
that output to [\fBerrorChannel\fR] rather than printing
directly to stderr.
.SH "SHORTCUT COMMANDS"
.TP
\fBdebug \fI?level?\fR
Same as [\fBconfigure -debug \fI?level?\fR].
.TP
\fBerrorFile \fI?filename?\fR
Same as [\fBconfigure -errfile \fI?filename?\fR].
.TP
\fBlimitConstraints \fI?boolean?\fR
Same as [\fBconfigure -limitconstraints \fI?boolean?\fR].
.TP
\fBloadFile \fI?filename?\fR
Same as [\fBconfigure -loadfile \fI?filename?\fR].
.TP
\fBloadScript \fI?script?\fR
Same as [\fBconfigure -load \fI?script?\fR].
.TP
\fBmatch \fI?patternList?\fR
Same as [\fBconfigure -match \fI?patternList?\fR].
.TP
\fBmatchDirectories \fI?patternList?\fR
Same as [\fBconfigure -relateddir \fI?patternList?\fR].
.TP
\fBmatchFiles \fI?patternList?\fR
Same as [\fBconfigure -file \fI?patternList?\fR].
.TP
\fBoutputFile \fI?filename?\fR
Same as [\fBconfigure -outfile \fI?filename?\fR].
.TP
\fBpreserveCore \fI?level?\fR
Same as [\fBconfigure -preservecore \fI?level?\fR].
.TP
\fBsingleProcess \fI?boolean?\fR
Same as [\fBconfigure -singleproc \fI?boolean?\fR].
.TP
\fBskip \fI?patternList?\fR
Same as [\fBconfigure -skip \fI?patternList?\fR].
.TP
\fBskipDirectories \fI?patternList?\fR
Same as [\fBconfigure -asidefromdir \fI?patternList?\fR].
.TP
\fBskipFiles \fI?patternList?\fR
Same as [\fBconfigure -notfile \fI?patternList?\fR].
.TP
\fBtemporaryDirectory \fI?directory?\fR
Same as [\fBconfigure -tmpdir \fI?directory?\fR].
.TP
\fBtestsDirectory \fI?directory?\fR
Same as [\fBconfigure -testdir \fI?directory?\fR].
.TP
\fBverbose \fI?level?\fR
Same as [\fBconfigure -verbose \fI?level?\fR].
.SH "OTHER COMMANDS"
.PP
The remaining commands provided by \fBtcltest\fR have better
alternatives provided by \fBtcltest\fR or \fBTcl\fR itself. They
are retained to support existing test suites, but should be avoided
in new code.
.TP
\fBtest\fR \fIname description optionList\fR
This form of [\fBtest\fR] was provided to enable passing many
options spanning several lines to [\fBtest\fR] as a single
argument quoted by braces, rather than needing to backslash quote
the newlines between arguments to [\fBtest\fR]. The \fIoptionList\fR
argument is expected to be a list with an even number of elements
representing \fIoption\fR and \fIvalue\fR arguments to pass
to [\fBtest\fR]. However, these values are not passed directly, as
in the alternate forms of [\fBswitch\fR]. Instead, this form makes
an unfortunate attempt to overthrow Tcl's substitution rules by
performing substitutions on some of the list elements as an attempt to
implement a ``do what I mean'' interpretation of a brace-enclosed
``block''. The result is nearly impossible to document clearly, and
for that reason this form is not recommended. See the examples in
\fBCREATING TEST SUITES WITH TCLTEST\fR below to see that this
form is really not necessary to avoid backslash-quoted newlines.
If you insist on using this form, examine
the source code of \fBtcltest\fR if you want to know the substitution
details, or just enclose the third through last argument
to [\fBtest\fR] in braces and hope for the best.
.TP
\fBworkingDirectory\fR \fI?directoryName?\fR
Sets or returns the current working directory when the test suite is
running. The default value for workingDirectory is the directory in
which the test suite was launched. The Tcl commands [\fBcd\fR] and
[\fBpwd\fR] are sufficient replacements.
.TP
\fBnormalizeMsg\fR \fImsg\fR
Returns the result of removing the ``extra'' newlines from \fImsg\fR,
where ``extra'' is rather imprecise. Tcl offers plenty of string
processing commands to modify strings as you wish, and
[\fBcustomMatch\fR] allows flexible matching of actual and expected
results.
.TP
\fBnormalizePath\fR \fIpathVar\fR
Resolves symlinks in a path, thus creating a path without internal
redirection. It is assumed that \fIpathVar\fR is absolute.
\fIpathVar\fR is modified in place. The Tcl command [\fBfile normalize\fR]
is a sufficient replacement.
.TP
\fBbytestring\fR \fIstring\fR
Construct a string that consists of the requested sequence of bytes,
as opposed to a string of properly formed UTF-8 characters using the
value supplied in \fIstring\fR. This allows the tester to create
denormalized or improperly formed strings to pass to C procedures that
are supposed to accept strings with embedded NULL types and confirm
that a string result has a certain pattern of bytes. This is
exactly equivalent to the Tcl command [\fBencoding convertfrom identity\fR].
.SH TESTS
.PP
The [\fBtest\fR] command is the heart of the \fBtcltest\fR package.
Its essential function is to evaluate a Tcl script and compare
the result with an expected result. The options of [\fBtest\fR]
define the test script, the environment in which to evaluate it,
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:
.DS
.ta 0.8i
test \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?
?-returnCodes \fIcodeList\fR?
?-match \fImode\fR?
.DE
The \fIname\fR may be any string. It is conventional to choose
a \fIname\fR according to the pattern:
.DS
\fItarget\fR-\fImajorNum\fR.\fIminorNum\fR
.DE
For white-box (regression) tests, the target should be the name of the
C function or Tcl procedure being tested. For black-box tests, the
target should be the name of the feature being tested. Some conventions
call for the names of black-box tests to have the suffix \fB_bb\fR.
Related tests should share a major number. As a test suite evolves,
it is best to have the same test name continue to correspond to the
same test, so that it remains meaningful to say things like ``Test
foo-1.3 passed in all releases up to 3.4, but began failing in
release 3.5.''
.PP
During evaluation of [\fBtest\fR], the \fIname\fR will be compared
to the lists of string matching patterns returned by
[\fBconfigure -match\fR], and [\fBconfigure -skip\fR]. The test
will be run only if \fIname\fR matches one of the patterns from
[\fBconfigure -match\fR] and matches none of the patterns
from [\fBconfigure -skip\fR].
.PP
The \fIdescription\fR should be a short textual description of the
test. The \fIdescription\fR is included in output produced by the
test, typically test failure messages. Good \fIdescription\fR values
should briefly explain the purpose of the test to users of a test suite.
The name of a Tcl or C function being tested should be included in the
description for regression tests. If the test case exists to reproduce
a bug, include the bug ID in the description.
.PP
Valid attributes and associated values are:
.TP
\fB-constraints \fIkeywordList|expression\fR
The optional \fB-constraints\fR attribute can be list of one or more
keywords or an expression. If the \fB-constraints\fR value is a list of
keywords, each of these keywords should be the name of a constraint
defined by a call to [\fBtestConstraint\fR]. If any of the listed
constraints is false or does not exist, the test is skipped. If the
\fB-constraints\fR value is an expression, that expression
is evaluated. If the expression evaluates to true, then the test is run.
Note that the expression form of \fB-constraints\fR may interfere with the
operation of [\fBconfigure -constraints\fR] and
[\fBconfigure -limitconstraints\fR], and is not recommended.
Appropriate constraints should be added to any tests that should
not always be run. That is, conditional evaluation of a test
should be accomplished by the \fB-constraints\fR option, not by
conditional evaluation of [\fBtest\fR]. In that way, the same
number of tests are always reported by the test suite, though
the number skipped may change based on the testing environment.
The default value is an empty list.
See \fBTEST CONSTRAINTS\fR below for a list of built-in constraints
and information on how to add your own constraints.
.TP
\fB-setup \fIscript\fR
The optional \fB-setup\fR attribute indicates a \fIscript\fR that will be run
before the script indicated by the \fB-body\fR attribute. If evaluation
of \fIscript\fR raises an error, the test will fail. The default value
is an empty script.
.TP
\fB-body \fIscript\fR
The \fB-body\fR attribute indicates the \fIscript\fR to run to carry out the
test. It must return a result that can be checked for correctness.
If evaluation of \fIscript\fR raises an error, the test will fail.
The default value is an empty script.
.TP
\fB-cleanup \fIscript\fR
The optional \fB-cleanup\fR attribute indicates a \fIscript\fR that will be
run after the script indicated by the \fB-body\fR attribute.
If evaluation of \fIscript\fR raises an error, the test will fail.
The default value is an empty script.
.TP
\fB-match \fImode\fR
The \fB-match\fR attribute determines how expected answers supplied by
\fB-result\fR, \fB-output\fR, and \fB-errorOutput\fR are compared. Valid
values for \fImode\fR are \fBregexp\fR, \fBglob\fR, \fBexact\fR, and
any value registered by a prior call to [\fBcustomMatch\fR]. The default
value is \fBexact\fR.
.TP
\fB-result \fIexpectedValue\fR
The \fB-result\fR attribute supplies the \fIexpectedValue\fR against which
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
[\fBputs\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 [\fBputs\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
a code not in the \fIexpectedCodeList\fR, the test fails. All
return codes known to [\fBreturn\fR], in both numeric and symbolic
form, including extended return codes, are acceptable elements in
the \fIexpectedCodeList\fR. Default value is \fB{ok return}\fR.
.PP
To pass, a test must successfully evaluate its \fB-setup\fR, \fB-body\fR,
and \fB-cleanup\fR scripts. The return code of the \fB-body\fR script and
its result must match expected values, and if specified, output and error
data from the test must match expected \fB-output\fR and \fB-errorOutput\fR
values. If any of these conditions are not met, then the test fails.
Note that all scripts are evaluated in the context of the caller
of [\fBtest\fR].
.PP
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 [\fBputs\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.
Each constraint has a name, which may be any string, and a boolean
value. Each [\fBtest\fR] has a \fB-constraints\fR value which is a
list of constraint names. There are two modes of constraint control.
Most frequently, the default mode is used, indicated by a setting
of [\fBconfigure -limitconstraints\fR] to false. The test will run
only if all constraints in the list are true-valued. Thus,
the \fB-constraints\fR option of [\fBtest\fR] is a convenient, symbolic
way to define any conditions required for the test to be possible or
meaningful. For example, a [\fBtest\fR] with \fB-constraints unix\fR
will only be run if the constraint \fBunix\fR is true, which indicates
the test suite is being run on a Unix platform.
.PP
Each [\fBtest\fR] should include whatever \fB-constraints\fR are
required to constrain it to run only where appropriate. Several
constraints are pre-defined in the \fBtcltest\fR package, listed
below. The registration of user-defined constraints is performed
by the [\fBtestConstraint\fR] command. User-defined constraints
may appear within a test file, or within the script specified
by the [\fBconfigure -load\fR] or [\fBconfigure -loadfile\fR]
options.
.PP
The following is a list of constraints pre-defined by the
\fBtcltest\fR package itself:
.TP
\fIsingleTestInterp\fR
test can only be run if all test files are sourced into a single interpreter
.TP
\fIunix\fR
test can only be run on any Unix platform
.TP
\fIwin\fR
test can only be run on any Windows platform
.TP
\fInt\fR
test can only be run on any Windows NT platform
.TP
\fI95\fR
test can only be run on any Windows 95 platform
.TP
\fI98\fR
test can only be run on any Windows 98 platform
.TP
\fImac\fR
test can only be run on any Mac platform
.TP
\fIunixOrWin\fR
test can only be run on a Unix or Windows platform
.TP
\fImacOrWin\fR
test can only be run on a Mac or Windows platform
.TP
\fImacOrUnix\fR
test can only be run on a Mac or Unix platform
.TP
\fItempNotWin\fR
test can not be run on Windows. This flag is used to temporarily
disable a test.
.TP
\fItempNotMac\fR
test can not be run on a Mac. This flag is used
to temporarily disable a test.
.TP
\fIunixCrash\fR
test crashes if it's run on Unix. This flag is used to temporarily
disable a test.
.TP
\fIwinCrash\fR
test crashes if it's run on Windows. This flag is used to temporarily
disable a test.
.TP
\fImacCrash\fR
test crashes if it's run on a Mac. This flag is used to temporarily
disable a test.
.TP
\fIemptyTest\fR
test is empty, and so not worth running, but it remains as a
place-holder for a test to be written in the future. This constraint
has value false to cause tests to be skipped unless the user specifies
otherwise.
.TP
\fIknownBug\fR
test is known to fail and the bug is not yet fixed. This constraint
has value false to cause tests to be skipped unless the user specifies
otherwise.
.TP
\fInonPortable\fR
test can only be run in some known development environment.
Some tests are inherently non-portable because they depend on things
like word length, file system configuration, window manager, etc.
This constraint has value false to cause tests to be skipped unless
the user specifies otherwise.
.TP
\fIuserInteraction\fR
test requires interaction from the user. This constraint has
value false to causes tests to be skipped unless the user specifies
otherwise.
.TP
\fIinteractive\fR
test can only be run in if the interpreter is in interactive mode
(when the global tcl_interactive variable is set to 1).
.TP
\fInonBlockFiles\fR
test can only be run if platform supports setting files into
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 | test can only run if Unix user is not root .TP \fIeformat\fR test can only run if app has a working version of sprintf with respect to the "e" format of floating-point numbers. .TP \fIstdio\fR | | > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | | > > > | | > > > > > > > > > > > > > > > | > > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > | < < < < < < < < < < < < < < < < < | < < < < < < < < < < < | < < < | < | < < < < < < < > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < < | | | < < < | | < < < < < < | > > > > | < < < > | > | < | < > | | < < | < < > | < < < > > | < | > | | < < < < < < < | < < < < | < | > > | | < > > > > | < | < > | < | < < < > > | < | < < | | < > | > > | | < < < | > | > | < | | < < > | < > | < < > < < < < < < < < < | | < < < | < < < < < < | < > > | < < < < < < < < | | < < > > | | > > > | < < < < > | > > > > > > < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | > > > | > > > > > > | | > | > > > < < < | < > | | < < < | | | < < | < < | | < < | < < < | | < | < < < < < > > > > > > > > > < | < < < < < < < < | | > | | < | | | < > | > | | < > | < < | < < | | < | | < > > > | | < < > | < | > > | | | < > | | | | < > | < > | < < < | < < < < < < < < | | | | < | | | | | | | | | | | | | | | 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 |
test can only run if Unix user is not root
.TP
\fIeformat\fR
test can only run if app has a working version of sprintf with respect
to the "e" format of floating-point numbers.
.TP
\fIstdio\fR
test can only be run if [\fBinterpreter\fR] can be [\fBopen\fR]ed
as a pipe.
.PP
The alternative mode of constraint control is enabled by setting
[\fBconfigure -limitconstraints\fR] to true. With that configuration
setting, all existing constraints other than those in the constraint
list returned by [\fBconfigure -constraints\fR] are set to false.
When the value of [\fBconfigure -constraints\fR]
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
configure -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 if 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
passed to the child processes as command line arguments,
with the exception of [\fBconfigure -outfile\fR]. The
[\fBrunAllTests\fR] command in the
master process collects all output from the child processes
and collates their results into one master report. Any
reports of individual test failures, or messages requested
by a [\fBconfigure -verbose\fR] setting are passed directly
on to [\fBoutputChannel\fR] by the master process.
.PP
After evaluating all selected test files, a summary of the
results is printed to [\fBoutputChannel\fR]. The summary
includes the total number of [\fBtest\fR]s evaluated, broken
down into those skipped, those passed, and those failed.
The summary also notes the number of files evaluated, and the names
of any files with failing tests or errors. A list of
the constraints that caused tests to be skipped, and the
number of tests skipped for each is also printed. Also,
messages are printed if it appears that evaluation of
a test file has caused any temporary files to be left
behind in [\fBconfigure -tmpdir\fR].
.PP
Having completed and summarized all selected test files,
[\fBrunAllTests\fR] then recursively acts on subdirectories
of [\fBconfigure -testdir\fR]. All subdirectories that
match any of the patterns in [\fBconfigure -relateddir\fR]
and do not match any of the patterns in
[\fBconfigure -asidefromdir\fR] are examined. If
a file named \fBall.tcl\fR is found in such a directory,
it will be [\fBsource\fR]d in the caller's context.
Whether or not an examined directory contains an
\fBall.tcl\fR file, its subdirectories are also scanned
against the [\fBconfigure -relateddir\fR] and
[\fBconfigure -asidefromdir\fR] patterns. In this way,
many directories in a directory tree can have all their
test files evaluated by a single [\fBrunAllTests\fR]
command.
.SH "CONFIGURABLE OPTIONS"
The [\fBconfigure\fR] command is used to set and query the configurable
options of \fBtcltest\fR. The valid options are:
.TP
\fB-singleproc \fIboolean\fR
Controls whether or not [\fBrunAllTests\fR] spawns a child process for
each test file. No spawning when \fIboolean\fR is true. Default
value is false.
.TP
\fB-debug \fIlevel\fR
Sets the debug level to \fIlevel\fR, an integer value indicating how
much debugging information should be printed to stdout. Note that
debug messages always go to stdout, independent of the value of
[\fBconfigure -outfile\fR]. Default value is 0. Levels are defined as:
.RS
.IP 0
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,
\fBskip\fR, \fBstart\fR, and \fBerror\fR. Default value is \fBbody\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)"
Print output when a test is skipped
.IP "start (t)"
Print output whenever a test starts
.IP "error (e)"
Print errorInfo and errorCode, if they exist, when a test return code
does not match its expected return code
.RE
The single letter abbreviations noted above are also recognized
so that [\fBconfigure -verbose pt\fR] is the same as
[\fBconfigure -verbose {pass start}\fR].
.TP
\fB-preservecore \fIlevel\fR
Sets the core preservation level to \fIlevel\fR. This level
determines how stringent checks for core files are. Default
value is 0. Levels are defined as:
.RS
.IP 0
No checking - do not check for core files at the end of each test
command, but do check for them in [\fBrunAllTests\fR] after all
test files have been evaluated.
.IP 1
Also check for core files at the end of each [\fBtest\fR] command.
.IP 2
Check for core files at all times described above, and save a
copy of each core file produced in [\fBconfigure -tmpdir\fR].
.RE
.TP
\fB-limitconstraints \fIboolean\fR
Sets the mode by which [\fBtest\fR] honors constraints as described
in \fBTESTS\fR above. Default value is false.
.TP
\fB-constraints \fIlist\fR
Sets all the constraints in \fIlist\fR to true. Also used in
combination with [\fBconfigure -limitconstraints true\fR] to control an
alternative constraint mode as described in \fBTESTS\fR above.
Default value is an empty list.
.TP
\fB-tmpdir \fIdirectory\fR
Sets the temporary directory to be used by [\fBmakeFile\fR],
[\fBmakeDirectory\fR], [\fBviewFile\fR], [\fBremoveFile\fR],
and [\fBremoveDirectory\fR] as the default directory where
temporary files and directories created by test files should
be created. Default value is [\fBworkingDirectory\fR].
.TP
\fB-testdir \fIdirectory\fR
Sets the directory searched by [\fBrunAllTests\fR] for test files
and subdirectories. Default value is [\fBworkingDirectory\fR].
.TP
\fB-file \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what test files to evaluate. Default value is \fB*.test\fR.
.TP
\fB-notfile \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what test files to skip. Default value is \fBl.*.test\fR, so
that any SCCS lock files are skipped.
.TP
\fB-relateddir \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what subdirectories to search for an \fBall.tcl\fR file. Default
value is \fB*\fR.
.TP
\fB-asidefromdir \fIpatternList\fR
Sets the list of patterns used by [\fBrunAllTests\fR] to determine
what subdirectories to skip when searching for an \fBall.tcl\fR file.
Default value is an empty list.
.TP
\fB-match \fIpatternList\fR
Set the list of patterns used by [\fBtest\fR] to determine whether
a test should be run. Default value is \fB*\fR.
.TP
\fB-skip \fIpatternList\fR
Set the list of patterns used by [\fBtest\fR] to determine whether
a test should be skipped. Default value is an empty list.
.TP
\fB-load \fIscript\fR
Sets a script to be evaluated by [\fBloadTestedCommands\fR].
Default value is an empty script.
.TP
\fB-loadfile \fIfilename\fR
Sets the filename from which to read a script to be evaluated
by [\fBloadTestedCommands\fR]. This is an alternative to
\fB-load\fR. They cannot be used together.
.TP
\fB-outfile \fIfilename\fR
Sets the file to which all output produced by tcltest should be
written. A file named \fIfilename\fR will be [\fBopen\fR]ed for writing,
and the resulting channel will be set as the value of [\fBoutputChannel\fR].
.TP
\fB-errfile \fIfilename\fR
Sets the file to which all error output produced by tcltest
should be written. A file named \fIfilename\fR will be [\fBopen\fR]ed
for writing, and the resulting channel will be set as the value
of [\fBerrorChannel\fR].
.SH "CREATING TEST SUITES WITH TCLTEST"
.PP
This section intentionally, temporarily left blank.
'\" .SH "CONTENTS OF A TEST FILE"
'\" Test files should begin by loading the \fBtcltest\fR package:
'\" .CS
'\" package require tcltest
'\" namespace import -force tcltest::*
'\" .CE
'\" Test files should end by cleaning up after themselves and calling
'\" \fBtcltest::cleanupTests\fR. The \fBtcltest::cleanupTests\fR
'\" procedure prints statistics about the number of tests that passed,
'\" skipped, and failed, and removes all files that were created using the
'\" \fBtcltest::makeFile\fR and \fBtcltest::makeDirectory\fR procedures.
'\" .CS
'\" # Remove files created by these tests
'\" # Change to original working directory
'\" # Unset global arrays
'\" tcltest::cleanupTests
'\" return
'\" .CE
'\" When naming test files, file names should end with a .test extension.
'\" The names of test files that contain regression (or glass-box) tests
'\" should correspond to the Tcl or C code file that they are testing.
'\" For example, the test file for the C file "tclCmdAH.c" is "cmdAH.test".
'\"
'\" .SH "HOW TO CUSTOMIZE THE TEST HARNESS"
'\" To create your own custom test harness, create a .tcl file that contains your
'\" namespace. Within this file, require package \fBtcltest\fR. Commands
'\" that can be redefined to customize the test harness include:
'\" .TP
'\" \fBtcltest::cleanupTestsHook\fR
'\" do additional cleanup
'\" .PP
'\" To add additional cleanup code to your harness
'\" you can define your own \fBtcltest::cleanupTestsHook\fR. For example:
'\" .CS
'\" proc tcltest::cleanupTestsHook {} {
'\" # Add your cleanup code here
'\" }
'\" .CE
'\"
'\" .SH EXAMPLES
'\" .IP [1]
'\" A simple test file (foo.test)
'\" .CS
'\" package require tcltest
'\" namespace import -force ::tcltest::*
'\"
'\" test foo-1.1 {save 1 in variable name foo} -body {set foo 1} -result 1
'\"
'\" tcltest::cleanupTests
'\" return
'\" .CE
'\" .IP [2]
'\" A simple all.tcl
'\" .CS
'\" package require tcltest
'\" namespace import -force ::tcltest::*
'\"
'\" tcltest::testsDirectory [file dir [info script]]
'\" tcltest::runAllTests
'\"
'\" return
'\" .CE
'\" .IP [3]
'\" Running a single test
'\" .CS
'\" tclsh foo.test
'\" .CE
'\" .IP [4]
'\" Running multiple tests
'\" .CS
'\" tclsh all.tcl -file 'foo*.test' -notfile 'foo2.test'
'\" .CE
'\" .IP [5]
'\" A test that uses the \fBunix\fR constraint and should only be
'\" run on Unix
'\" .CS
'\" test getAttribute-1.1 {testing file permissions} {
'\" -constraints {unix}
'\" -body {
'\" lindex [file attributes foo.tcl] 5
'\" }
'\" -result {00644}
'\" }
'\" .CE
'\" .IP [6]
'\" A test containing an constraint expression that evaluates to true (a case where the test would be run) if it is being run on unix and if threads are not being tested
'\" .CS
'\" test testOnUnixWithoutThreads-1.1 {
'\" this test runs only on unix and only if we're not testing
'\" threads
'\" } {
'\" -constraints {unix && !testthread}
'\" -body {
'\" # some script goes here
'\" }
'\" }
'\" .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 tcltest::configure $::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
test level-1.1 {level 1} {
-body {
test 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-errorOuput\fR
options to [\fBtest\fR] is useful only for pure Tcl applications
that use [\fBputs\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.9.4.3 2002/08/20 20:25:24 das 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 |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | capitalization are converted automatically to upper case. For instance, the PATH variable could be exported by the operating system as ``path'', ``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to support many special cases. All other environment variables inherited by Tcl are left unmodified. Setting an env array variable to blank is the same as unsetting it as this is the behavior of the underlying Windows OS. It should be noted that relying on an existing and empty environment variable | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | capitalization are converted automatically to upper case. For instance, the PATH variable could be exported by the operating system as ``path'', ``Path'', ``PaTh'', etc., causing otherwise simple Tcl code to have to support many special cases. All other environment variables inherited by Tcl are left unmodified. Setting an env array variable to blank is the same as unsetting it as this is the behavior of the underlying Windows OS. It should be noted that relying on an existing and empty environment variable won't work on windows and is discouraged for cross-platform usage. .VE .RE .RS On the Macintosh, the environment variable is constructed by Tcl as no global environment variable exists. The environment variables that are created for Tcl include: .TP |
| ︙ | ︙ | |||
254 255 256 257 258 259 260 | \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 | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 | \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 debugging symbols enabled. 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 loaded. .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. |
| ︙ | ︙ |
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 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | '\" '\" 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.8.14.1 2002/08/20 20:25:24 das 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 .SH SYNOPSIS \fBtrace \fIoption\fR ?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP This command causes Tcl commands to be executed whenever certain operations are invoked. The legal \fIoption\fR's (which may be abbreviated) are: .TP \fBtrace add \fItype name ops ?args?\fR Where \fItype\fR is \fBcommand\fR, \fBexecution\fR, or \fBvariable\fR. .RS .TP \fBtrace add command\fR \fIname ops command\fR Arrange for \fIcommand\fR to be executed whenever command \fIname\fR is modified in one of the ways given 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. |
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | \fBdelete\fR Invoke \fIcommand\fR when the command is deleted. Commands can be deleted explicitly by using the \fBrename\fR command to rename the command to an empty string. Commands are also deleted when the interpreter is deleted, but traces will not be invoked because there is no interpreter in which to execute them. .PP | | > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
\fBdelete\fR
Invoke \fIcommand\fR when the command is deleted. Commands can be
deleted explicitly by using the \fBrename\fR command to rename the
command to an empty string. Commands are also deleted when the
interpreter is deleted, but traces will not be invoked because there is no
interpreter in which to execute them.
.PP
When the trace triggers, depending on the operations being traced, a
number of arguments are appended to \fIcommand\fR so that the actual
command is as follows:
.CS
\fIcommand oldName newName op\fR
.CE
\fIOldName\fR and \fInewName\fR give the traced command's current
(old) name, and the name to which it is being renamed (the empty
string if this is a 'delete' operation).
\fIOp\fR indicates what operation is being performed on the
command, and is one of \fBrename\fR or \fBdelete\fR as
defined above. The trace operation cannot be used to stop a command
from being deleted. Tcl will always remove the command once the trace
is complete. Recursive renaming or deleting will not cause further traces
of the same type to be evaluated, so a delete trace which itself
deletes the command, or a rename trace which itself renames the
command will not cause further trace evaluations to occur.
.RE
.TP
\fBtrace add execution\fR \fIname ops command\fR
Arrange for \fIcommand\fR to be executed whenever command \fIname\fR
is modified in one of the ways given 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 a \fIenterstep\fR trace would be
invoked just before \fIputs "hello"\fR is executed.
Setting a \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
command is as follows:
For \fBenter\fR and \fBenterstep\fR operations:
.CS
\fIcommand command-string op\fR
.CE
\fICommand-string\fR gives the complete current command being
executed (the traced command for a \fBenter\fR operation, an
arbitrary command for a \fBenterstep\fR operation), including
all arguments in their fully expanded form.
\fIOp\fR indicates what operation is being performed on the
command execution, and is one of \fBenter\fR or \fBenterstep\fR as
defined above. The trace operation can be used to stop the
command from executing, by deleting the command in question. Of
course when the command is subsequently executed, an 'invalid command'
error will occur.
.TP
For \fBleave\fR and \fBleavestep\fR operations:
.CS
\fIcommand command-string code result op\fR
.CE
\fICommand-string\fR gives the complete current command being
executed (the traced command for a \fBenter\fR operation, an
arbitrary command for a \fBenterstep\fR operation), including
all arguments in their fully expanded form.
\fICode\fR gives the result code of that execution, and \fIresult\fR
the result string.
\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.
\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.
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
\fIcommand\fR name as a whole will return that same error.
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.
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
refer to a normal variable, an element of an array, or to an array
as a whole (i.e. \fIname\fR may be just the name of an array, with no
parenthesized index). If \fIname\fR refers to a whole array, then
|
| ︙ | ︙ | |||
179 180 181 182 183 184 185 | but will not remove traces on the overall array. .PP This command returns an empty string. .RE .RE .TP \fBtrace remove \fItype name opList command\fR | | > > > > > > > | | | > > > > > > > > | | | 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 | but will not remove traces on the overall array. .PP This command returns an empty string. .RE .RE .TP \fBtrace remove \fItype name opList command\fR Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR. .RS .TP \fBtrace remove command\fI name opList command\fR If there is a trace set on command \fIname\fR with the operations and command given by \fIopList\fR and \fIcommand\fR, then the trace is removed, so that \fIcommand\fR will never again be invoked. Returns an empty string. If \fIname\fR doesn't exist, the command will throw an error. .TP \fBtrace remove execution\fI name opList command\fR If there is a trace set on command \fIname\fR with the operations and command given by \fIopList\fR and \fIcommand\fR, then the trace is removed, so that \fIcommand\fR will never again be invoked. Returns an empty string. If \fIname\fR doesn't exist, the command will throw an error. .TP \fBtrace remove variable\fI name opList command\fR If there is a trace set on variable \fIname\fR with the operations and command given by \fIopList\fR and \fIcommand\fR, then the trace is removed, so that \fIcommand\fR will never again be invoked. Returns an empty string. .RE .TP \fBtrace info \fItype name\fR Where \fItype\fR is either \fBcommand\fR, \fBexecution\fR or \fBvariable\fR. .RS .TP \fBtrace info command\fI name\fR Returns a list containing one element for each trace currently set on command \fIname\fR. Each element of the list is itself a list containing two elements, which are the \fIopList\fR and \fIcommand\fR associated with the trace. If \fIname\fR doesn't have any traces set, then the result of the command will be an empty string. If \fIname\fR doesn't exist, the command will throw an error. .TP \fBtrace info execution\fI name\fR Returns a list containing one element for each trace currently set on command \fIname\fR. Each element of the list is itself a list containing two elements, which are the \fIopList\fR and \fIcommand\fR associated with the trace. If \fIname\fR doesn't have any traces set, then the result of the command will be an empty string. If \fIname\fR doesn't exist, the command will throw an error. .TP \fBtrace info variable\fI name\fR Returns a list containing one element for each trace currently set on variable \fIname\fR. Each element of the list is itself a list containing two elements, which are the \fIopList\fR and \fIcommand\fR associated with the trace. If \fIname\fR doesn't exist or doesn't have any traces set, then the result of the command will be an empty string. .RE .PP For backwards compatibility, three other subcommands are available: .RS .TP \fBtrace variable \fIname ops command\fR This is equivalent to \fBtrace add variable \fIname ops command\fR. .TP \fBtrace vdelete \fIname ops command\fR This is equivalent to \fBtrace remove variable \fIname ops command\fR .TP \fBtrace vinfo \fIname\fR This is equivalent to \fBtrace info variable \fIname\fR .RE .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 |
| ︙ | ︙ |
Changes to generic/regc_cvec.c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | /* - newcvec - allocate a new cvec ^ static struct cvec *newcvec(int, int, int); */ static struct cvec * newcvec(nchrs, nranges, nmcces) | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | > | | | | | | | | | | | > > | | | > > | | | | | | | < | | > | | > | | | | > | | | | 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 |
/*
- newcvec - allocate a new cvec
^ static struct cvec *newcvec(int, int, int);
*/
static struct cvec *
newcvec(nchrs, nranges, nmcces)
int nchrs; /* to hold this many chrs... */
int nranges; /* ... and this many ranges... */
int nmcces; /* ... and this many MCCEs */
{
size_t n;
size_t nc;
struct cvec *cv;
nc = (size_t)nchrs + (size_t)nmcces*(MAXMCCE+1) + (size_t)nranges*2;
n = sizeof(struct cvec) + (size_t)(nmcces-1)*sizeof(chr *)
+ nc*sizeof(chr);
cv = (struct cvec *)MALLOC(n);
if (cv == NULL) {
return NULL;
}
cv->chrspace = nchrs;
cv->chrs = (chr *)&cv->mcces[nmcces]; /* chrs just after MCCE ptrs */
cv->mccespace = nmcces;
cv->ranges = cv->chrs + nchrs + nmcces*(MAXMCCE+1);
cv->rangespace = nranges;
return clearcvec(cv);
}
/*
- clearcvec - clear a possibly-new cvec
* Returns pointer as convenience.
^ static struct cvec *clearcvec(struct cvec *);
*/
static struct cvec *
clearcvec(cv)
struct cvec *cv; /* character vector */
{
int i;
assert(cv != NULL);
cv->nchrs = 0;
assert(cv->chrs == (chr *)&cv->mcces[cv->mccespace]);
cv->nmcces = 0;
cv->nmccechrs = 0;
cv->nranges = 0;
for (i = 0; i < cv->mccespace; i++) {
cv->mcces[i] = NULL;
}
return cv;
}
/*
- addchr - add a chr to a cvec
^ static VOID addchr(struct cvec *, pchr);
*/
static VOID
addchr(cv, c)
struct cvec *cv; /* character vector */
pchr c; /* character to add */
{
assert(cv->nchrs < cv->chrspace - cv->nmccechrs);
cv->chrs[cv->nchrs++] = (chr)c;
}
/*
- addrange - add a range to a cvec
^ static VOID addrange(struct cvec *, pchr, pchr);
*/
static VOID
addrange(cv, from, to)
struct cvec *cv; /* character vector */
pchr from; /* first character of range */
pchr to; /* last character of range */
{
assert(cv->nranges < cv->rangespace);
cv->ranges[cv->nranges*2] = (chr)from;
cv->ranges[cv->nranges*2 + 1] = (chr)to;
cv->nranges++;
}
/*
- addmcce - add an MCCE to a cvec
^ static VOID addmcce(struct cvec *, chr *, chr *);
*/
static VOID
addmcce(cv, startp, endp)
struct cvec *cv; /* character vector */
chr *startp; /* beginning of text */
chr *endp; /* just past end of text */
{
int len;
int i;
chr *s;
chr *d;
if (startp == NULL && endp == NULL) {
return;
}
len = endp - startp;
assert(len > 0);
assert(cv->nchrs + len < cv->chrspace - cv->nmccechrs);
assert(cv->nmcces < cv->mccespace);
d = &cv->chrs[cv->chrspace - cv->nmccechrs - len - 1];
cv->mcces[cv->nmcces++] = d;
for (s = startp, i = len; i > 0; s++, i--) {
*d++ = *s;
}
*d++ = 0; /* endmarker */
assert(d == &cv->chrs[cv->chrspace - cv->nmccechrs]);
cv->nmccechrs += len + 1;
}
/*
- haschr - does a cvec contain this chr?
^ static int haschr(struct cvec *, pchr);
*/
static int /* predicate */
haschr(cv, c)
struct cvec *cv; /* character vector */
pchr c; /* character to test for */
{
int i;
chr *p;
for (p = cv->chrs, i = cv->nchrs; i > 0; p++, i--) {
if (*p == c) {
return 1;
}
}
for (p = cv->ranges, i = cv->nranges; i > 0; p += 2, i--) {
if ((*p <= c) && (c <= *(p+1))) {
return 1;
}
}
return 0;
}
/*
- getcvec - get a cvec, remembering it as v->cv
^ static struct cvec *getcvec(struct vars *, int, int, int);
*/
static struct cvec *
getcvec(v, nchrs, nranges, nmcces)
struct vars *v; /* context */
int nchrs; /* to hold this many chrs... */
int nranges; /* ... and this many ranges... */
int nmcces; /* ... and this many MCCEs */
{
if (v->cv != NULL && nchrs <= v->cv->chrspace &&
nranges <= v->cv->rangespace && nmcces <= v->cv->mccespace) {
return clearcvec(v->cv);
}
if (v->cv != NULL) {
freecvec(v->cv);
}
v->cv = newcvec(nchrs, nranges, nmcces);
if (v->cv == NULL) {
ERR(REG_ESPACE);
}
return v->cv;
}
/*
- freecvec - free a cvec
^ static VOID freecvec(struct cvec *);
*/
static VOID
freecvec(cv)
struct cvec *cv; /* character vector */
{
FREE(cv);
}
|
Changes to generic/regc_locale.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * regc_locale.c -- * * This file contains the Unicode locale specific regexp routines. * This file is #included by regcomp.c. * * 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 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 |
/*
* regc_locale.c --
*
* This file contains the Unicode locale specific regexp routines.
* This file is #included by regcomp.c.
*
* 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: regc_locale.c,v 1.6.10.3 2002/08/20 20:25:24 das Exp $
*/
/* ASCII character-name table */
static struct cname {
char *name;
char code;
} cnames[] = {
{"NUL", '\0'},
{"SOH", '\001'},
{"STX", '\002'},
{"ETX", '\003'},
{"EOT", '\004'},
{"ENQ", '\005'},
{"ACK", '\006'},
{"BEL", '\007'},
{"alert", '\007'},
{"BS", '\010'},
{"backspace", '\b'},
{"HT", '\011'},
{"tab", '\t'},
{"LF", '\012'},
{"newline", '\n'},
{"VT", '\013'},
{"vertical-tab", '\v'},
{"FF", '\014'},
{"form-feed", '\f'},
{"CR", '\015'},
{"carriage-return", '\r'},
{"SO", '\016'},
{"SI", '\017'},
{"DLE", '\020'},
{"DC1", '\021'},
{"DC2", '\022'},
{"DC3", '\023'},
{"DC4", '\024'},
{"NAK", '\025'},
{"SYN", '\026'},
{"ETB", '\027'},
{"CAN", '\030'},
{"EM", '\031'},
{"SUB", '\032'},
{"ESC", '\033'},
{"IS4", '\034'},
{"FS", '\034'},
{"IS3", '\035'},
{"GS", '\035'},
{"IS2", '\036'},
{"RS", '\036'},
{"IS1", '\037'},
{"US", '\037'},
{"space", ' '},
{"exclamation-mark",'!'},
{"quotation-mark", '"'},
{"number-sign", '#'},
{"dollar-sign", '$'},
{"percent-sign", '%'},
{"ampersand", '&'},
{"apostrophe", '\''},
{"left-parenthesis",'('},
{"right-parenthesis", ')'},
{"asterisk", '*'},
{"plus-sign", '+'},
{"comma", ','},
{"hyphen", '-'},
{"hyphen-minus", '-'},
{"period", '.'},
{"full-stop", '.'},
{"slash", '/'},
{"solidus", '/'},
{"zero", '0'},
{"one", '1'},
{"two", '2'},
{"three", '3'},
{"four", '4'},
{"five", '5'},
{"six", '6'},
{"seven", '7'},
{"eight", '8'},
{"nine", '9'},
{"colon", ':'},
{"semicolon", ';'},
{"less-than-sign", '<'},
{"equals-sign", '='},
{"greater-than-sign", '>'},
{"question-mark", '?'},
{"commercial-at", '@'},
{"left-square-bracket", '['},
{"backslash", '\\'},
{"reverse-solidus", '\\'},
{"right-square-bracket", ']'},
{"circumflex", '^'},
{"circumflex-accent", '^'},
{"underscore", '_'},
{"low-line", '_'},
{"grave-accent", '`'},
{"left-brace", '{'},
{"left-curly-bracket", '{'},
{"vertical-line", '|'},
{"right-brace", '}'},
{"right-curly-bracket", '}'},
{"tilde", '~'},
{"DEL", '\177'},
{NULL, 0}
};
/* Unicode character-class tables */
typedef struct crange {
chr start;
chr end;
|
| ︙ | ︙ | |||
522 523 524 525 526 527 528 | /* - nmcces - how many distinct MCCEs are there? ^ static int nmcces(struct vars *); */ static int nmcces(v) | | > > > | | | | | | | | | | | | | | | | | | | > | | | | | | | > > | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | > | | | > | | | | | | | | | | | | | | | | > | | | | | | | | | 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 |
/*
- nmcces - how many distinct MCCEs are there?
^ static int nmcces(struct vars *);
*/
static int
nmcces(v)
struct vars *v; /* context */
{
/*
* No multi-character collating elements defined at the moment.
*/
return 0;
}
/*
- nleaders - how many chrs can be first chrs of MCCEs?
^ static int nleaders(struct vars *);
*/
static int
nleaders(v)
struct vars *v; /* context */
{
return 0;
}
/*
- allmcces - return a cvec with all the MCCEs of the locale
^ static struct cvec *allmcces(struct vars *, struct cvec *);
*/
static struct cvec *
allmcces(v, cv)
struct vars *v; /* context */
struct cvec *cv; /* this is supposed to have enough room */
{
return clearcvec(cv);
}
/*
- element - map collating-element name to celt
^ static celt element(struct vars *, chr *, chr *);
*/
static celt
element(v, startp, endp)
struct vars *v; /* context */
chr *startp; /* points to start of name */
chr *endp; /* points just past end of name */
{
struct cname *cn;
size_t len;
Tcl_DString ds;
CONST char *np;
/* generic: one-chr names stand for themselves */
assert(startp < endp);
len = endp - startp;
if (len == 1) {
return *startp;
}
NOTE(REG_ULOCALE);
/* search table */
Tcl_DStringInit(&ds);
np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
for (cn=cnames; cn->name!=NULL; cn++) {
if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) {
break; /* NOTE BREAK OUT */
}
}
Tcl_DStringFree(&ds);
if (cn->name != NULL) {
return CHR(cn->code);
}
/* couldn't find it */
ERR(REG_ECOLLATE);
return 0;
}
/*
- range - supply cvec for a range, including legality check
^ static struct cvec *range(struct vars *, celt, celt, int);
*/
static struct cvec *
range(v, a, b, cases)
struct vars *v; /* context */
celt a; /* range start */
celt b; /* range end, might equal a */
int cases; /* case-independent? */
{
int nchrs;
struct cvec *cv;
celt c, lc, uc, tc;
if (a != b && !before(a, b)) {
ERR(REG_ERANGE);
return NULL;
}
if (!cases) { /* easy version */
cv = getcvec(v, 0, 1, 0);
NOERRN();
addrange(cv, a, b);
return cv;
}
/*
* When case-independent, it's hard to decide when cvec ranges are
* usable, so for now at least, we won't try. We allocate enough
* space for two case variants plus a little extra for the two
* title case variants.
*/
nchrs = (b - a + 1)*2 + 4;
cv = getcvec(v, nchrs, 0, 0);
NOERRN();
for (c=a; c<=b; c++) {
addchr(cv, c);
lc = Tcl_UniCharToLower((chr)c);
uc = Tcl_UniCharToUpper((chr)c);
tc = Tcl_UniCharToTitle((chr)c);
if (c != lc) {
addchr(cv, lc);
}
if (c != uc) {
addchr(cv, uc);
}
if (c != tc && tc != uc) {
addchr(cv, tc);
}
}
return cv;
}
/*
- before - is celt x before celt y, for purposes of range legality?
^ static int before(celt, celt);
*/
static int /* predicate */
before(x, y)
celt x, y; /* collating elements */
{
/* trivial because no MCCEs */
if (x < y) {
return 1;
}
return 0;
}
/*
- eclass - supply cvec for an equivalence class
* Must include case counterparts on request.
^ static struct cvec *eclass(struct vars *, celt, int);
*/
static struct cvec *
eclass(v, c, cases)
struct vars *v; /* context */
celt c; /* Collating element representing
* the equivalence class. */
int cases; /* all cases? */
{
struct cvec *cv;
/* crude fake equivalence class for testing */
if ((v->cflags®_FAKE) && c == 'x') {
cv = getcvec(v, 4, 0, 0);
addchr(cv, (chr)'x');
addchr(cv, (chr)'y');
if (cases) {
addchr(cv, (chr)'X');
addchr(cv, (chr)'Y');
}
return cv;
}
/* otherwise, none */
if (cases) {
return allcases(v, c);
}
cv = getcvec(v, 1, 0, 0);
assert(cv != NULL);
addchr(cv, (chr)c);
return cv;
}
/*
- cclass - supply cvec for a character class
* Must include case counterparts on request.
^ static struct cvec *cclass(struct vars *, chr *, chr *, int);
*/
static struct cvec *
cclass(v, startp, endp, cases)
struct vars *v; /* context */
chr *startp; /* where the name starts */
chr *endp; /* just past the end of the name */
int cases; /* case-independent? */
{
size_t len;
struct cvec *cv = NULL;
Tcl_DString ds;
CONST char *np;
char **namePtr;
int i, index;
|
| ︙ | ︙ | |||
751 752 753 754 755 756 757 |
}
/*
* Map the name to the corresponding enumerated value.
*/
index = -1;
| | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | < | | | > > | 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 |
}
/*
* Map the name to the corresponding enumerated value.
*/
index = -1;
for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) {
if ((strlen(*namePtr) == len) && (strncmp(*namePtr, np, len) == 0)) {
index = i;
break;
}
}
Tcl_DStringInit(&ds);
if (index == -1) {
ERR(REG_ECTYPE);
return NULL;
}
/*
* Now compute the character class contents.
*/
switch((enum classes) index) {
case CC_PRINT:
case CC_ALNUM:
cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE, 0);
if (cv) {
for (i=0 ; i<NUM_ALPHA_CHAR ; i++) {
addchr(cv, alphaCharTable[i]);
}
for (i=0 ; i<NUM_ALPHA_RANGE ; i++) {
addrange(cv, alphaRangeTable[i].start,
alphaRangeTable[i].end);
}
for (i=0 ; i<NUM_DIGIT_RANGE ; i++) {
addrange(cv, digitRangeTable[i].start,
digitRangeTable[i].end);
}
}
break;
case CC_ALPHA:
cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE, 0);
if (cv) {
for (i=0 ; i<NUM_ALPHA_RANGE ; i++) {
addrange(cv, alphaRangeTable[i].start,
alphaRangeTable[i].end);
}
for (i=0 ; i<NUM_ALPHA_CHAR ; i++) {
addchr(cv, alphaCharTable[i]);
}
}
break;
case CC_ASCII:
cv = getcvec(v, 0, 1, 0);
if (cv) {
addrange(cv, 0, 0x7f);
}
break;
case CC_BLANK:
cv = getcvec(v, 2, 0, 0);
addchr(cv, '\t');
addchr(cv, ' ');
break;
case CC_CNTRL:
cv = getcvec(v, 0, 2, 0);
addrange(cv, 0x0, 0x1f);
addrange(cv, 0x7f, 0x9f);
break;
case CC_DIGIT:
cv = getcvec(v, 0, NUM_DIGIT_RANGE, 0);
if (cv) {
for (i=0 ; i<NUM_DIGIT_RANGE ; i++) {
addrange(cv, digitRangeTable[i].start,
digitRangeTable[i].end);
}
}
break;
case CC_PUNCT:
cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE, 0);
if (cv) {
for (i=0 ; i<NUM_PUNCT_RANGE ; i++) {
addrange(cv, punctRangeTable[i].start,
punctRangeTable[i].end);
}
for (i=0 ; i<NUM_PUNCT_CHAR ; i++) {
addchr(cv, punctCharTable[i]);
}
}
break;
case CC_XDIGIT:
/*
* This is a 3 instead of (NUM_DIGIT_RANGE+2) because I've no
* idea how to define the digits 'a' through 'f' in
* non-western locales. The concept is quite possibly non
* portable, or only used in contextx where the characters
* used would be the western ones anyway! Whatever is
* actually the case, the number of ranges is fixed (until
* someone comes up with a better arrangement!)
*/
cv = getcvec(v, 0, 3, 0);
if (cv) {
addrange(cv, '0', '9');
addrange(cv, 'a', 'f');
addrange(cv, 'A', 'F');
}
break;
case CC_SPACE:
cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE, 0);
if (cv) {
for (i=0 ; i<NUM_SPACE_RANGE ; i++) {
addrange(cv, spaceRangeTable[i].start,
spaceRangeTable[i].end);
}
for (i=0 ; i<NUM_SPACE_CHAR ; i++) {
addchr(cv, spaceCharTable[i]);
}
}
break;
case CC_LOWER:
cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE, 0);
if (cv) {
for (i=0 ; i<NUM_LOWER_RANGE ; i++) {
addrange(cv, lowerRangeTable[i].start,
lowerRangeTable[i].end);
}
for (i=0 ; i<NUM_LOWER_CHAR ; i++) {
addchr(cv, lowerCharTable[i]);
}
}
break;
case CC_UPPER:
cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE, 0);
if (cv) {
for (i=0 ; i<NUM_UPPER_RANGE ; i++) {
addrange(cv, upperRangeTable[i].start,
upperRangeTable[i].end);
}
for (i=0 ; i<NUM_UPPER_CHAR ; i++) {
addchr(cv, upperCharTable[i]);
}
}
break;
case CC_GRAPH:
cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE, 0);
if (cv) {
for (i=0 ; i<NUM_GRAPH_RANGE ; i++) {
addrange(cv, graphRangeTable[i].start,
graphRangeTable[i].end);
}
for (i=0 ; i<NUM_GRAPH_CHAR ; i++) {
addchr(cv, graphCharTable[i]);
}
}
break;
}
if (cv == NULL) {
ERR(REG_ESPACE);
}
return cv;
}
/*
- allcases - supply cvec for all case counterparts of a chr (including itself)
* This is a shortcut, preferably an efficient one, for simple characters;
* messy cases are done via range().
^ static struct cvec *allcases(struct vars *, pchr);
*/
static struct cvec *
allcases(v, pc)
struct vars *v; /* context */
pchr pc; /* character to get case equivs of */
{
struct cvec *cv;
chr c = (chr)pc;
chr lc, uc, tc;
lc = Tcl_UniCharToLower((chr)c);
uc = Tcl_UniCharToUpper((chr)c);
tc = Tcl_UniCharToTitle((chr)c);
if (tc != uc) {
cv = getcvec(v, 3, 0, 0);
addchr(cv, tc);
} else {
cv = getcvec(v, 2, 0, 0);
}
addchr(cv, lc);
if (lc != uc) {
addchr(cv, uc);
}
return cv;
}
/*
- cmp - chr-substring compare
* Backrefs need this. It should preferably be efficient.
* Note that it does not need to report anything except equal/unequal.
* Note also that the length is exact, and the comparison should not
* stop at embedded NULs!
^ static int cmp(CONST chr *, CONST chr *, size_t);
*/
static int /* 0 for equal, nonzero for unequal */
cmp(x, y, len)
CONST chr *x, *y; /* strings to compare */
size_t len; /* exact length of comparison */
{
return memcmp(VS(x), VS(y), len*sizeof(chr));
}
/*
- casecmp - case-independent chr-substring compare
* REG_ICASE backrefs need this. It should preferably be efficient.
* Note that it does not need to report anything except equal/unequal.
* Note also that the length is exact, and the comparison should not
* stop at embedded NULs!
^ static int casecmp(CONST chr *, CONST chr *, size_t);
*/
static int /* 0 for equal, nonzero for unequal */
casecmp(x, y, len)
CONST chr *x, *y; /* strings to compare */
size_t len; /* exact length of comparison */
{
for (; len > 0; len--, x++, y++) {
if ((*x!=*y) && (Tcl_UniCharToLower(*x) != Tcl_UniCharToLower(*y))) {
return 1;
}
}
return 0;
}
|
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 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
# 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.63.2.4 2002/08/20 20:25:24 das Exp $
library tcl
# Define the tcl interface with several sub interfaces:
# tclPlat - platform specific public
# tclInt - generic private
# tclPlatInt - platform specific private
interface tcl
hooks {tclPlat tclInt tclIntPlat}
# Declare each of the functions in the public Tcl interface. Note that
# the an index should never be reused for a different function in order
# to preserve backwards compatibility.
declare 0 generic {
int Tcl_PkgProvideEx(Tcl_Interp* interp, CONST char* name,
CONST char* version, ClientData clientData)
}
declare 1 generic {
CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact, ClientData *clientDataPtr)
}
declare 2 generic {
void Tcl_Panic(CONST char *format, ...)
}
declare 3 generic {
char * Tcl_Alloc(unsigned int size)
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
declare 80 generic {
void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData)
}
declare 81 generic {
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 82 generic {
| | | | 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 |
declare 80 generic {
void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData)
}
declare 81 generic {
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 82 generic {
int Tcl_CommandComplete(CONST char *cmd)
}
declare 83 generic {
char * Tcl_Concat(int argc, CONST84 char * CONST *argv)
}
declare 84 generic {
int Tcl_ConvertElement(CONST char *src, char *dst, int flags)
}
declare 85 generic {
int Tcl_ConvertCountedElement(CONST char *src, int length, char *dst,
int flags)
}
declare 86 generic {
int Tcl_CreateAlias(Tcl_Interp *slave, CONST char *slaveCmd,
Tcl_Interp *target, CONST char *targetCmd, int argc,
CONST84 char * CONST *argv)
}
declare 87 generic {
int Tcl_CreateAliasObj(Tcl_Interp *slave, CONST char *slaveCmd,
Tcl_Interp *target, CONST char *targetCmd, int objc,
Tcl_Obj *CONST objv[])
}
declare 88 generic {
|
| ︙ | ︙ | |||
457 458 459 460 461 462 463 |
declare 125 generic {
void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
}
declare 126 generic {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 generic {
| | | | | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
declare 125 generic {
void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
}
declare 126 generic {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 generic {
CONST84_RETURN char * Tcl_ErrnoId(void)
}
declare 128 generic {
CONST84_RETURN char * Tcl_ErrnoMsg(int err)
}
declare 129 generic {
int Tcl_Eval(Tcl_Interp *interp, CONST char *string)
}
# This is obsolete, use Tcl_FSEvalFile
declare 130 generic {
int Tcl_EvalFile(Tcl_Interp *interp, CONST char *fileName)
}
declare 131 generic {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 |
}
declare 147 generic {
void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 generic {
int Tcl_GetAlias(Tcl_Interp *interp, CONST char *slaveCmd,
Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
| | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
}
declare 147 generic {
void Tcl_FreeResult(Tcl_Interp *interp)
}
declare 148 generic {
int Tcl_GetAlias(Tcl_Interp *interp, CONST char *slaveCmd,
Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
int *argcPtr, CONST84 char ***argvPtr)
}
declare 149 generic {
int Tcl_GetAliasObj(Tcl_Interp *interp, CONST char *slaveCmd,
Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 generic {
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 |
declare 154 generic {
ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
declare 155 generic {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 generic {
| | | > | | 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 |
declare 154 generic {
ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
declare 155 generic {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 generic {
CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 generic {
int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
CONST char *optionName, Tcl_DString *dsPtr)
}
declare 158 generic {
Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan)
}
declare 159 generic {
int Tcl_GetCommandInfo(Tcl_Interp *interp, CONST char *cmdName,
Tcl_CmdInfo *infoPtr)
}
declare 160 generic {
CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command)
}
declare 161 generic {
int Tcl_GetErrno(void)
}
declare 162 generic {
CONST84_RETURN char * Tcl_GetHostName(void)
}
declare 163 generic {
int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp)
}
declare 164 generic {
Tcl_Interp * Tcl_GetMaster(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 |
declare 172 generic {
Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, CONST char *slaveName)
}
declare 173 generic {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 generic {
| | | > | | | | 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 |
declare 172 generic {
Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, CONST char *slaveName)
}
declare 173 generic {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 generic {
CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp)
}
declare 175 generic {
CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, CONST char *varName,
int flags)
}
declare 176 generic {
CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, CONST char *part1,
CONST char *part2, int flags)
}
declare 177 generic {
int Tcl_GlobalEval(Tcl_Interp *interp, CONST char *command)
}
declare 178 generic {
int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 generic {
int Tcl_HideCommand(Tcl_Interp *interp, CONST char *cmdName,
CONST char *hiddenCmdToken)
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
}
# Obsolete, use Tcl_FSJoinPath
declare 186 generic {
char * Tcl_JoinPath(int argc, CONST84 char * CONST *argv,
Tcl_DString *resultPtr)
}
declare 187 generic {
| | > | 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
}
# Obsolete, use Tcl_FSJoinPath
declare 186 generic {
char * Tcl_JoinPath(int argc, CONST84 char * CONST *argv,
Tcl_DString *resultPtr)
}
declare 187 generic {
int Tcl_LinkVar(Tcl_Interp *interp, CONST char *varName, char *addr,
int type)
}
# This slot is reserved for use by the plus patch:
# declare 188 generic {
# Tcl_MainLoop
# }
|
| ︙ | ︙ | |||
723 724 725 726 727 728 729 |
declare 202 generic {
void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
declare 203 generic {
int Tcl_PutEnv(CONST char *string)
}
declare 204 generic {
| | | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 |
declare 202 generic {
void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
declare 203 generic {
int Tcl_PutEnv(CONST char *string)
}
declare 204 generic {
CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 generic {
void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
}
declare 206 generic {
int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
}
|
| ︙ | ︙ | |||
830 831 832 833 834 835 836 |
declare 235 generic {
void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 generic {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 237 generic {
| | | | | | | 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 |
declare 235 generic {
void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 generic {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 237 generic {
CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, CONST char *varName,
CONST char *newValue, int flags)
}
declare 238 generic {
CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, CONST char *part1,
CONST char *part2, CONST char *newValue, int flags)
}
declare 239 generic {
CONST84_RETURN char * Tcl_SignalId(int sig)
}
declare 240 generic {
CONST84_RETURN char * Tcl_SignalMsg(int sig)
}
declare 241 generic {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 generic {
int Tcl_SplitList(Tcl_Interp *interp, CONST char *listStr, int *argcPtr,
CONST84 char ***argvPtr)
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 |
int Tcl_StringMatch(CONST char *str, CONST char *pattern)
}
# Obsolete
declare 246 generic {
int Tcl_TellOld(Tcl_Channel chan)
}
declare 247 generic {
| | | | | | | | | > | | | | | | | 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 |
int Tcl_StringMatch(CONST char *str, CONST char *pattern)
}
# Obsolete
declare 246 generic {
int Tcl_TellOld(Tcl_Channel chan)
}
declare 247 generic {
int Tcl_TraceVar(Tcl_Interp *interp, CONST char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 248 generic {
int Tcl_TraceVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
int flags, Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 249 generic {
char * Tcl_TranslateFileName(Tcl_Interp *interp, CONST char *name,
Tcl_DString *bufferPtr)
}
declare 250 generic {
int Tcl_Ungets(Tcl_Channel chan, CONST char *str, int len, int atHead)
}
declare 251 generic {
void Tcl_UnlinkVar(Tcl_Interp *interp, CONST char *varName)
}
declare 252 generic {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 253 generic {
int Tcl_UnsetVar(Tcl_Interp *interp, CONST char *varName, int flags)
}
declare 254 generic {
int Tcl_UnsetVar2(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
int flags)
}
declare 255 generic {
void Tcl_UntraceVar(Tcl_Interp *interp, CONST char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 256 generic {
void Tcl_UntraceVar2(Tcl_Interp *interp, CONST char *part1,
CONST char *part2, int flags, Tcl_VarTraceProc *proc,
ClientData clientData)
}
declare 257 generic {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, CONST char *varName)
}
declare 258 generic {
int Tcl_UpVar(Tcl_Interp *interp, CONST char *frameName,
CONST char *varName, CONST char *localName, int flags)
}
declare 259 generic {
int Tcl_UpVar2(Tcl_Interp *interp, CONST char *frameName, CONST char *part1,
CONST char *part2, CONST char *localName, int flags)
}
declare 260 generic {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
declare 261 generic {
ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, CONST char *varName,
int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
}
declare 262 generic {
ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, CONST char *part1,
CONST char *part2, int flags, Tcl_VarTraceProc *procPtr,
ClientData prevClientData)
}
declare 263 generic {
int Tcl_Write(Tcl_Channel chan, CONST char *s, int slen)
}
declare 264 generic {
|
| ︙ | ︙ | |||
945 946 947 948 949 950 951 |
declare 267 generic {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
declare 268 generic {
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 generic {
| | | > | | | | 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 |
declare 267 generic {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
declare 268 generic {
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 generic {
CONST84_RETURN char * Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 generic {
CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, CONST char *str,
CONST84 char **termPtr)
}
declare 271 generic {
CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, CONST char *name,
CONST char *version, int exact)
}
declare 272 generic {
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)
}
declare 276 generic {
int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
|
| ︙ | ︙ | |||
1038 1039 1040 1041 1042 1043 1044 |
declare 289 generic {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 290 generic {
void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 generic {
| | > | 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 |
declare 289 generic {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 290 generic {
void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 generic {
int Tcl_EvalEx(Tcl_Interp *interp, CONST char *script, int numBytes,
int flags)
}
declare 292 generic {
int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[],
int flags)
}
declare 293 generic {
int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
|
| ︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 |
declare 300 generic {
Tcl_ThreadId Tcl_GetCurrentThread(void)
}
declare 301 generic {
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 302 generic {
| | | | | 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 |
declare 300 generic {
Tcl_ThreadId Tcl_GetCurrentThread(void)
}
declare 301 generic {
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 302 generic {
CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 generic {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 generic {
int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
CONST VOID *tablePtr, int offset, CONST char *msg, int flags,
int *indexPtr)
}
declare 305 generic {
VOID * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
}
declare 306 generic {
Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, CONST char *part1,
CONST char *part2, int flags)
}
declare 307 generic {
ClientData Tcl_InitNotifier(void)
}
declare 308 generic {
void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
}
|
| ︙ | ︙ | |||
1126 1127 1128 1129 1130 1131 1132 |
declare 315 generic {
void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 316 generic {
int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 317 generic {
| | | | 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 |
declare 315 generic {
void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 316 generic {
int Tcl_SetSystemEncoding(Tcl_Interp *interp, CONST char *name)
}
declare 317 generic {
Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, CONST char *part1,
CONST char *part2, Tcl_Obj *newValuePtr, int flags)
}
declare 318 generic {
void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 generic {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event* evPtr,
Tcl_QueuePosition position)
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 |
declare 323 generic {
Tcl_UniChar Tcl_UniCharToUpper(int ch)
}
declare 324 generic {
int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 generic {
| | | | | | | 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 |
declare 323 generic {
Tcl_UniChar Tcl_UniCharToUpper(int ch)
}
declare 324 generic {
int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 generic {
CONST84_RETURN char * Tcl_UtfAtIndex(CONST char *src, int index)
}
declare 326 generic {
int Tcl_UtfCharComplete(CONST char *src, int len)
}
declare 327 generic {
int Tcl_UtfBackslash(CONST char *src, int *readPtr, char *dst)
}
declare 328 generic {
CONST84_RETURN char * Tcl_UtfFindFirst(CONST char *src, int ch)
}
declare 329 generic {
CONST84_RETURN char * Tcl_UtfFindLast(CONST char *src, int ch)
}
declare 330 generic {
CONST84_RETURN char * Tcl_UtfNext(CONST char *src)
}
declare 331 generic {
CONST84_RETURN char * Tcl_UtfPrev(CONST char *src, CONST char *start)
}
declare 332 generic {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
CONST char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
|
| ︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 |
declare 339 generic {
int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 generic {
char * Tcl_GetString(Tcl_Obj *objPtr)
}
declare 341 generic {
| | | 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 |
declare 339 generic {
int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 generic {
char * Tcl_GetString(Tcl_Obj *objPtr)
}
declare 341 generic {
CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void)
}
declare 342 generic {
void Tcl_SetDefaultEncodingDir(CONST char *path)
}
declare 343 generic {
void Tcl_AlertNotifier(ClientData clientData)
}
|
| ︙ | ︙ | |||
1268 1269 1270 1271 1272 1273 1274 |
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 generic {
void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script,
CONST char *command, int length)
}
declare 360 generic {
| | | | | | | > | | 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 |
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 generic {
void Tcl_LogCommandInfo(Tcl_Interp *interp, CONST char *script,
CONST char *command, int length)
}
declare 360 generic {
int Tcl_ParseBraces(Tcl_Interp *interp, CONST char *string, int numBytes,
Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
}
declare 361 generic {
int Tcl_ParseCommand(Tcl_Interp *interp, CONST char *string, int numBytes,
int nested, Tcl_Parse *parsePtr)
}
declare 362 generic {
int Tcl_ParseExpr(Tcl_Interp *interp, CONST char *string, int numBytes,
Tcl_Parse *parsePtr)
}
declare 363 generic {
int Tcl_ParseQuotedString(Tcl_Interp *interp, CONST char *string,
int numBytes, Tcl_Parse *parsePtr, int append,
CONST84 char **termPtr)
}
declare 364 generic {
int Tcl_ParseVarName(Tcl_Interp *interp, CONST char *string, int numBytes,
Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
declare 365 generic {
char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
|
| ︙ | ︙ | |||
1397 1398 1399 1400 1401 1402 1403 |
declare 396 generic {
Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
}
declare 397 generic {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 generic {
| | | 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 |
declare 396 generic {
Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
}
declare 397 generic {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 generic {
CONST84_RETURN char * Tcl_ChannelName(Tcl_ChannelType *chanTypePtr)
}
declare 399 generic {
Tcl_ChannelTypeVersion Tcl_ChannelVersion(Tcl_ChannelType *chanTypePtr)
}
declare 400 generic {
Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(Tcl_ChannelType
*chanTypePtr)
|
| ︙ | ︙ | |||
1565 1566 1567 1568 1569 1570 1571 |
int Tcl_FSDeleteFile(Tcl_Obj *pathPtr)
}
declare 444 generic {
int Tcl_FSLoadFile(Tcl_Interp * interp,
Tcl_Obj *pathPtr, CONST char * sym1, CONST char * sym2,
Tcl_PackageInitProc ** proc1Ptr,
Tcl_PackageInitProc ** proc2Ptr,
| | | | 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 |
int Tcl_FSDeleteFile(Tcl_Obj *pathPtr)
}
declare 444 generic {
int Tcl_FSLoadFile(Tcl_Interp * interp,
Tcl_Obj *pathPtr, CONST char * sym1, CONST char * sym2,
Tcl_PackageInitProc ** proc1Ptr,
Tcl_PackageInitProc ** proc2Ptr,
Tcl_LoadHandle * handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr)
}
declare 445 generic {
int Tcl_FSMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *result,
Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)
}
declare 446 generic {
Tcl_Obj * Tcl_FSLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction)
}
declare 447 generic {
int Tcl_FSRemoveDirectory(Tcl_Obj *pathPtr,
int recursive, Tcl_Obj **errorPtr)
}
declare 448 generic {
int Tcl_FSRenameFile(Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)
|
| ︙ | ︙ | |||
1645 1646 1647 1648 1649 1650 1651 |
declare 466 generic {
Tcl_Obj* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr)
}
declare 467 generic {
int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
}
declare 468 generic {
| | | 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 |
declare 466 generic {
Tcl_Obj* Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr)
}
declare 467 generic {
int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
}
declare 468 generic {
Tcl_Obj* Tcl_FSNewNativePath(Tcl_Filesystem* fromFilesystem,
ClientData clientData)
}
declare 469 generic {
CONST char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr)
}
declare 470 generic {
Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr)
|
| ︙ | ︙ | |||
1815 1816 1817 1818 1819 1820 1821 |
int strcasecmp(CONST char *s1, CONST char *s2)
}
##################
# Mac OS X declarations
#
| | | | | | < < < < < | 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 |
int strcasecmp(CONST char *s1, CONST char *s2)
}
##################
# Mac OS X declarations
#
declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
CONST char *bundleName,
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 | * 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.103.2.4 2002/08/20 20:25:24 das Exp $ */ #ifndef _TCL #define _TCL /* * For C++ compilers, use extern "C" |
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | * 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 | < < < | | | | < < < < < < < < < > > > < < < < < < < < < < < < < > | < < | | < < | | < < | | > | > | > > > | | | > | > > > > > | | | 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 | * 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) * 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_BETA_RELEASE #define TCL_RELEASE_SERIAL 3 #define TCL_VERSION "8.4" #define TCL_PATCH_LEVEL "8.4b3" /* * The following definitions set up the proper options for Windows * compilers. We use this method because there is no autoconf equivalent. */ #ifndef __WIN32__ # if defined(_WIN32) || defined(WIN32) || defined(__CYGWIN__) || defined(__MINGW32__) || defined(__BORLANDC__) # define __WIN32__ # ifndef WIN32 # define WIN32 # endif # endif #endif /* * STRICT: See MSDN Article Q83456 */ #ifdef __WIN32__ # ifndef STRICT # define STRICT # endif #endif /* __WIN32__ */ /* * The following definitions set up the proper options for Macintosh * compilers. We use this method because there is no autoconf equivalent. */ #ifdef MAC_TCL #include <ConditionalMacros.h> # ifndef USE_TCLALLOC # define USE_TCLALLOC 1 # endif # ifndef NO_STRERROR # define NO_STRERROR 1 # endif # define INLINE #endif /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. */ #ifndef STRINGIFY # define STRINGIFY(x) STRINGIFY1(x) # define STRINGIFY1(x) #x #endif #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif /* * A special definition used to allow this header file to be included * from windows resource files so that they can obtain version * information. RC_INVOKED is defined by default by the RC tool. * Resource compilers don't like all the C stuff, like typedefs and * procedure declarations, that occur below, so block them out. */ #ifndef RC_INVOKED /* * A special definition for Macintosh used to allow this header file * to be included in resource files so that they can get obtain * version information from this file. Resource compilers don't like * all the C stuff, like typedefs and procedure declarations, that * occur below. */ #ifndef RESOURCE_INCLUDED /* * Special macro to define mutexes, that doesn't do anything * if we are not using threads. */ #ifdef TCL_THREADS #define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; |
| ︙ | ︙ | |||
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | #define Tcl_MutexLock(mutexPtr) #define Tcl_MutexUnlock(mutexPtr) #define Tcl_MutexFinalize(mutexPtr) #define Tcl_ConditionNotify(condPtr) #define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) #define Tcl_ConditionFinalize(condPtr) #endif /* TCL_THREADS */ #ifndef BUFSIZ # include <stdio.h> #endif /* * Definitions that allow Tcl functions with variable numbers of * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS * is used in procedure prototypes. TCL_VARARGS_DEF is used to declare * the arguments in a function definiton: it takes the type and name of * the first argument and supplies the appropriate argument declaration * string for use in the function definition. TCL_VARARGS_START * initializes the va_list data structure and returns the first argument. */ | > | < < < < < < | 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 | #define Tcl_MutexLock(mutexPtr) #define Tcl_MutexUnlock(mutexPtr) #define Tcl_MutexFinalize(mutexPtr) #define Tcl_ConditionNotify(condPtr) #define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) #define Tcl_ConditionFinalize(condPtr) #endif /* TCL_THREADS */ #ifndef BUFSIZ # include <stdio.h> #endif /* * Definitions that allow Tcl functions with variable numbers of * arguments to be used with either varargs.h or stdarg.h. TCL_VARARGS * is used in procedure prototypes. TCL_VARARGS_DEF is used to declare * the arguments in a function definiton: it takes the type and name of * the first argument and supplies the appropriate argument declaration * string for use in the function definition. TCL_VARARGS_START * initializes the va_list data structure and returns the first argument. */ #if !defined(NO_STDARG) # include <stdarg.h> # define TCL_VARARGS(type, name) (type name, ...) # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) #else # include <varargs.h> # define TCL_VARARGS(type, name) () # define TCL_VARARGS_DEF(type, name) (va_alist) # define TCL_VARARGS_START(type, name, list) \ (va_start(list), va_arg(list, type)) #endif /* * Macros used to declare a function to be exported by a DLL. * Used by Windows, maps to no-op declarations on non-Windows systems. * The default build on windows is for a DLL, which causes the DLLIMPORT * and DLLEXPORT macros to be nonempty. To build a static library, the * macro STATIC_BUILD should be defined. |
| ︙ | ︙ | |||
263 264 265 266 267 268 269 | */ #undef _ANSI_ARGS_ #undef CONST #ifndef INLINE # define INLINE #endif | < < | > > > > | > | > > > > > > > > | > > > > > > > > > > > > > > > > | | < | < | < < < < < < < < < < < < | | | | < | 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 | */ #undef _ANSI_ARGS_ #undef CONST #ifndef INLINE # define INLINE #endif #ifndef NO_CONST # define CONST const #else # define CONST #endif #ifndef NO_PROTOTYPES # define _ANSI_ARGS_(x) x #else # define _ANSI_ARGS_(x) () #endif #ifdef USE_NON_CONST # ifdef USE_COMPAT_CONST # error define at most one of USE_NON_CONST and USE_COMPAT_CONST # endif # define CONST84 # define CONST84_RETURN #else # ifdef USE_COMPAT_CONST # define CONST84 # define CONST84_RETURN CONST # else # define CONST84 CONST # define CONST84_RETURN CONST # endif #endif /* * Make sure EXTERN isn't defined elsewhere */ #ifdef EXTERN # undef EXTERN #endif /* EXTERN */ #ifdef __cplusplus # define EXTERN extern "C" TCL_STORAGE_CLASS #else # define EXTERN extern TCL_STORAGE_CLASS #endif /* * The following code is copied from winnt.h. * If we don't replicate it here, then <windows.h> can't be included * after tcl.h, since tcl.h also defines VOID. */ #ifdef __WIN32__ #ifndef VOID #define VOID void typedef char CHAR; typedef short SHORT; typedef long LONG; #endif #endif /* __WIN32__ */ /* * Macro to use instead of "void" for arguments that must have * type "void *" in ANSI C; maps them to type "char *" in * non-ANSI systems. */ #ifndef NO_VOID # define VOID void #else # define VOID char #endif /* * Miscellaneous declarations. */ #ifndef NULL # define NULL 0 #endif #ifndef _CLIENTDATA # ifndef NO_VOID typedef void *ClientData; # else typedef int *ClientData; # endif # define _CLIENTDATA #endif /* * 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.) * * At the moment, this only works on Unix systems anyway... |
| ︙ | ︙ | |||
362 363 364 365 366 367 368 369 370 371 372 373 374 375 | * implementation (in tclObj.c) depends on the functions strtoull() * and, where sprintf(...,"%lld",...) does not work, lltostr(). * Although strtoull() is fairly straight-forward, lltostr() is a most * unusual function on Solaris8 (taking its operating buffer * backwards) so any changes you make will need to be done * cautiously... */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # ifdef __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 | > | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 | * implementation (in tclObj.c) depends on the functions strtoull() * and, where sprintf(...,"%lld",...) does not work, lltostr(). * Although strtoull() is fairly straight-forward, lltostr() is a most * unusual function on Solaris8 (taking its operating buffer * backwards) so any changes you make will need to be done * cautiously... */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # ifdef __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 |
| ︙ | ︙ | |||
400 401 402 403 404 405 406 | # define TCL_WIDE_INT_TYPE long #endif /* TCL_WIDE_INT_IS_LONG */ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #ifdef TCL_WIDE_INT_IS_LONG | < < < < < < | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 | # define TCL_WIDE_INT_TYPE long #endif /* TCL_WIDE_INT_IS_LONG */ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #ifdef TCL_WIDE_INT_IS_LONG typedef struct stat Tcl_StatBuf; # define Tcl_WideAsLong(val) ((long)(val)) # define Tcl_LongAsWide(val) ((long)(val)) # define Tcl_WideAsDouble(val) ((double)((long)(val))) # define Tcl_DoubleAsWide(val) ((long)((double)(val))) #else /* TCL_WIDE_INT_IS_LONG */ # ifndef __WIN32__ # ifdef HAVE_STRUCT_STAT64 typedef struct stat64 Tcl_StatBuf; # else typedef struct stat Tcl_StatBuf; # endif /* HAVE_STRUCT_STAT64 */ # define TCL_LL_MODIFIER "ll" # define TCL_LL_MODIFIER_SIZE 2 |
| ︙ | ︙ | |||
489 490 491 492 493 494 495 | typedef struct Tcl_RegExp_ *Tcl_RegExp; typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey; typedef struct Tcl_ThreadId_ *Tcl_ThreadId; typedef struct Tcl_TimerToken_ *Tcl_TimerToken; typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; | | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 | typedef struct Tcl_RegExp_ *Tcl_RegExp; typedef struct Tcl_ThreadDataKey_ *Tcl_ThreadDataKey; typedef struct Tcl_ThreadId_ *Tcl_ThreadId; typedef struct Tcl_TimerToken_ *Tcl_TimerToken; typedef struct Tcl_Trace_ *Tcl_Trace; typedef struct Tcl_Var_ *Tcl_Var; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle; /* * Definition of the interface to procedures implementing threads. * A procedure following this definition is given to each call of * 'Tcl_CreateThread' and will be called as the main fuction of * the new thread created by that call. */ |
| ︙ | ︙ | |||
666 667 668 669 670 671 672 | typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int code)); typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask)); typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data)); typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData)); typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData, | | | | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
typedef int (Tcl_AppInitProc) _ANSI_ARGS_((Tcl_Interp *interp));
typedef int (Tcl_AsyncProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int code));
typedef void (Tcl_ChannelProc) _ANSI_ARGS_((ClientData clientData, int mask));
typedef void (Tcl_CloseProc) _ANSI_ARGS_((ClientData data));
typedef void (Tcl_CmdDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_CmdProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST84 char *argv[]));
typedef void (Tcl_CmdTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc,
ClientData cmdClientData, int argc, CONST84 char *argv[]));
typedef int (Tcl_CmdObjTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, CONST char *command,
Tcl_Command commandInfo, int objc, struct Tcl_Obj * CONST * objv));
typedef void (Tcl_CmdObjTraceDeleteProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_DupInternalRepProc) _ANSI_ARGS_((struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr));
typedef int (Tcl_EncodingConvertProc)_ANSI_ARGS_((ClientData clientData,
|
| ︙ | ︙ | |||
710 711 712 713 714 715 716 |
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
| | | | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 |
typedef void (Tcl_TcpAcceptProc) _ANSI_ARGS_((ClientData callbackData,
Tcl_Channel chan, char *address, int port));
typedef void (Tcl_TimerProc) _ANSI_ARGS_((ClientData clientData));
typedef int (Tcl_SetFromAnyProc) _ANSI_ARGS_((Tcl_Interp *interp,
struct Tcl_Obj *objPtr));
typedef void (Tcl_UpdateStringProc) _ANSI_ARGS_((struct Tcl_Obj *objPtr));
typedef char *(Tcl_VarTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST84 char *part1, CONST84 char *part2, int flags));
typedef void (Tcl_CommandTraceProc) _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *oldName, CONST char *newName,
int flags));
typedef void (Tcl_CreateFileHandlerProc) _ANSI_ARGS_((int fd, int mask,
Tcl_FileProc *proc, ClientData clientData));
typedef void (Tcl_DeleteFileHandlerProc) _ANSI_ARGS_((int fd));
typedef void (Tcl_AlertNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_ServiceModeHookProc) _ANSI_ARGS_((int mode));
typedef ClientData (Tcl_InitNotifierProc) _ANSI_ARGS_((VOID));
typedef void (Tcl_FinalizeNotifierProc) _ANSI_ARGS_((ClientData clientData));
typedef void (Tcl_MainLoopProc) _ANSI_ARGS_((void));
/*
* The following structure represents a type of object, which is a
* particular internal representation for an object plus a set of
|
| ︙ | ︙ | |||
1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 | * Flag values passed to Tcl_RecordAndEval and/or Tcl_EvalObj. * WARNING: these bit choices must not conflict with the bit choices * for evalFlag bits in tclInt.h!! */ #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 #define TCL_EVAL_DIRECT 0x40000 /* * Special freeProc values that may be passed to Tcl_SetResult (see * the man page for details): */ #define TCL_VOLATILE ((Tcl_FreeProc *) 1) #define TCL_STATIC ((Tcl_FreeProc *) 0) | > | 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 | * Flag values passed to Tcl_RecordAndEval and/or Tcl_EvalObj. * WARNING: these bit choices must not conflict with the bit choices * for evalFlag bits in tclInt.h!! */ #define TCL_NO_EVAL 0x10000 #define TCL_EVAL_GLOBAL 0x20000 #define TCL_EVAL_DIRECT 0x40000 #define TCL_EVAL_INVOKE 0x80000 /* * Special freeProc values that may be passed to Tcl_SetResult (see * the man page for details): */ #define TCL_VOLATILE ((Tcl_FreeProc *) 1) #define TCL_STATIC ((Tcl_FreeProc *) 0) |
| ︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 | */ #define TCL_TRACE_RENAME 0x2000 #define TCL_TRACE_DELETE 0x4000 #define TCL_ALLOW_INLINE_COMPILATION 0x20000 /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. * The part1 is now always parsed whenever the part2 is NULL. * (This is to avoid a common error when converting code to * use the new object based APIs and forgetting to give the * flag) */ | > > > > > > > > | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 | */ #define TCL_TRACE_RENAME 0x2000 #define TCL_TRACE_DELETE 0x4000 #define TCL_ALLOW_INLINE_COMPILATION 0x20000 /* * Flag values passed to Tcl_CreateObjTrace, and used internally * by command execution traces. Slots 4,8,16 and 32 are * used internally by execution traces (see tclCmdMZ.c) */ #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. * The part1 is now always parsed whenever the part2 is NULL. * (This is to avoid a common error when converting code to * use the new object based APIs and forgetting to give the * flag) */ |
| ︙ | ︙ | |||
1606 1607 1608 1609 1610 1611 1612 | /* * Typedefs for the various filesystem operations: */ typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)); typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, | | | | | | < < < | | 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 | /* * Typedefs for the various filesystem operations: */ typedef int (Tcl_FSStatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); typedef int (Tcl_FSAccessProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int mode)); typedef Tcl_Channel (Tcl_FSOpenFileChannelProc) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions)); typedef int (Tcl_FSMatchInDirectoryProc) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *result, Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData * types)); typedef Tcl_Obj* (Tcl_FSGetCwdProc) _ANSI_ARGS_((Tcl_Interp *interp)); typedef int (Tcl_FSChdirProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); typedef int (Tcl_FSLstatProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf)); typedef int (Tcl_FSCreateDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); typedef int (Tcl_FSDeleteFileProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); typedef int (Tcl_FSCopyDirectoryProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr)); typedef int (Tcl_FSCopyFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)); typedef int (Tcl_FSRemoveDirectoryProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr)); typedef int (Tcl_FSRenameFileProc) _ANSI_ARGS_((Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr)); typedef void (Tcl_FSUnloadFileProc) _ANSI_ARGS_((Tcl_LoadHandle loadHandle)); typedef Tcl_Obj* (Tcl_FSListVolumesProc) _ANSI_ARGS_((void)); /* We have to declare the utime structure here. */ struct utimbuf; typedef int (Tcl_FSUtimeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, struct utimbuf *tval)); typedef int (Tcl_FSNormalizePathProc) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint)); typedef int (Tcl_FSFileAttrsGetProc) _ANSI_ARGS_((Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)); typedef CONST char** (Tcl_FSFileAttrStringsProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj** objPtrRef)); typedef int (Tcl_FSFileAttrsSetProc) _ANSI_ARGS_((Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)); typedef Tcl_Obj* (Tcl_FSLinkProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType)); typedef int (Tcl_FSLoadFileProc) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr)); typedef int (Tcl_FSPathInFilesystemProc) _ANSI_ARGS_((Tcl_Obj *pathPtr, ClientData *clientDataPtr)); typedef Tcl_Obj* (Tcl_FSFilesystemPathTypeProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); typedef Tcl_Obj* (Tcl_FSFilesystemSeparatorProc) _ANSI_ARGS_((Tcl_Obj *pathPtr)); |
| ︙ | ︙ | |||
1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 |
* carry out the correct action (i.e. call
* the correct system 'chdir' api). If not
* implemented, then 'cd' and 'pwd' will
* fail inside the filesystem.
*/
} Tcl_Filesystem;
/*
* The following structure represents the Notifier functions that
* you can override with the Tcl_SetNotifier call.
*/
typedef struct Tcl_NotifierProcs {
Tcl_SetTimerProc *setTimerProc;
| > > > > > > > > > > > | 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 |
* carry out the correct action (i.e. call
* the correct system 'chdir' api). If not
* implemented, then 'cd' and 'pwd' will
* fail inside the filesystem.
*/
} Tcl_Filesystem;
/*
* The following definitions are used as values for the 'linkAction' flag
* to Tcl_FSLink, or the linkProc of any filesystem. Any combination
* of flags can be given. For link creation, the linkProc should create
* a link which matches any of the types given.
*
* TCL_CREATE_SYMBOLIC_LINK: Create a symbolic or soft link.
* TCL_CREATE_HARD_LINK: Create a hard link.
*/
#define TCL_CREATE_SYMBOLIC_LINK 0x01
#define TCL_CREATE_HARD_LINK 0x02
/*
* The following structure represents the Notifier functions that
* you can override with the Tcl_SetNotifier call.
*/
typedef struct Tcl_NotifierProcs {
Tcl_SetTimerProc *setTimerProc;
|
| ︙ | ︙ | |||
1955 1956 1957 1958 1959 1960 1961 |
* For each word of a command, and for each piece of a word such as a
* variable reference, one of the following structures is created to
* describe the token.
*/
typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD;
* see below for valid types. */
| | | 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 |
* For each word of a command, and for each piece of a word such as a
* variable reference, one of the following structures is created to
* describe the token.
*/
typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD;
* see below for valid types. */
CONST char *start; /* First character in token. */
int size; /* Number of bytes in token. */
int numComponents; /* If this token is composed of other
* tokens, this field tells how many of
* them there are (including components of
* components, etc.). The component tokens
* immediately follow this one. */
} Tcl_Token;
|
| ︙ | ︙ | |||
2069 2070 2071 2072 2073 2074 2075 |
/*
* A structure of the following type is filled in by Tcl_ParseCommand.
* It describes a single command parsed from an input string.
*/
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
| | | | 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 |
/*
* A structure of the following type is filled in by Tcl_ParseCommand.
* It describes a single command parsed from an input string.
*/
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
CONST char *commentStart; /* Pointer to # that begins the first of
* one or more comments preceding the
* command. */
int commentSize; /* Number of bytes in comments (up through
* newline character that terminates the
* last comment). If there were no
* comments, this field is 0. */
CONST char *commandStart; /* First character in first word of command. */
int commandSize; /* Number of bytes in command, including
* first character of first word, up
* through the terminating newline,
* close bracket, or semicolon. */
int numWords; /* Total number of words in command. May
* be 0. */
Tcl_Token *tokenPtr; /* Pointer to first token representing
|
| ︙ | ︙ | |||
2100 2101 2102 2103 2104 2105 2106 |
/*
* The fields below are intended only for the private use of the
* parser. They should not be used by procedures that invoke
* Tcl_ParseCommand.
*/
| | | | | 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 |
/*
* The fields below are intended only for the private use of the
* parser. They should not be used by procedures that invoke
* Tcl_ParseCommand.
*/
CONST char *string; /* The original command string passed to
* Tcl_ParseCommand. */
CONST char *end; /* Points to the character just after the
* last one in the command string. */
Tcl_Interp *interp; /* Interpreter to use for error reporting,
* or NULL. */
CONST char *term; /* Points to character in string that
* terminated most recent token. Filled in
* by ParseTokens. If an error occurs,
* points to beginning of region where the
* error occurred (e.g. the open brace if
* the close brace is missing). */
int incomplete; /* This field is set to 1 by Tcl_ParseCommand
* if the command appears to be incomplete.
|
| ︙ | ︙ | |||
2275 2276 2277 2278 2279 2280 2281 | * class is neither DLLEXPORT nor DLLIMPORT */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); | | > > | 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 | * class is neither DLLEXPORT nor DLLIMPORT */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS EXTERN int Tcl_AppInit _ANSI_ARGS_((Tcl_Interp *interp)); #endif /* RC_INVOKED */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #endif /* RESOURCE_INCLUDED */ /* * end block for C++ */ #ifdef __cplusplus } #endif #endif /* _TCL */ |
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.35.8.3 2002/08/20 20:25:25 das Exp $ */ #include "tclInt.h" #include "tclCompile.h" #ifndef TCL_GENERIC_ONLY # include "tclPort.h" #endif |
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
iPtr->interpInfo = NULL;
Tcl_InitHashTable(&iPtr->mathFuncTable, TCL_STRING_KEYS);
iPtr->numLevels = 0;
iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
iPtr->framePtr = NULL;
iPtr->varFramePtr = NULL;
| | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 |
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;
|
| ︙ | ︙ | |||
353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
iPtr->resolverPtr = NULL;
iPtr->evalFlags = 0;
iPtr->scriptFile = NULL;
iPtr->flags = 0;
iPtr->tracePtr = NULL;
iPtr->tracesForbiddingInline = 0;
iPtr->activeCmdTracePtr = 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 */
| > | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 |
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 */
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
}
/*
* Register the builtin math functions.
*/
i = 0;
| | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 |
}
/*
* Register the builtin math functions.
*/
i = 0;
for (builtinFuncPtr = tclBuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
Tcl_CreateMathFunc((Tcl_Interp *) iPtr, builtinFuncPtr->name,
builtinFuncPtr->numArgs, builtinFuncPtr->argTypes,
(Tcl_MathProc *) NULL, (ClientData) 0);
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable,
builtinFuncPtr->name);
if (hPtr == NULL) {
|
| ︙ | ︙ | |||
1748 1749 1750 1751 1752 1753 1754 |
/*
* This procedure generates an argv array for the string arguments. It
* starts out with stack-allocated space but uses dynamically-allocated
* storage if needed.
*/
#define NUM_ARGS 20
| | | | | 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 |
/*
* This procedure generates an argv array for the string arguments. It
* starts out with stack-allocated space but uses dynamically-allocated
* storage if needed.
*/
#define NUM_ARGS 20
CONST char *(argStorage[NUM_ARGS]);
CONST char **argv = argStorage;
/*
* Create the string argument array "argv". Make sure argv is large
* enough to hold the objc arguments plus 1 extra for the zero
* end-of-argv word.
*/
if ((objc + 1) > NUM_ARGS) {
argv = (CONST char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
}
for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetString(objv[i]);
}
argv[objc] = 0;
|
| ︙ | ︙ | |||
1809 1810 1811 1812 1813 1814 1815 |
*/
int
TclInvokeObjectCommand(clientData, interp, argc, argv)
ClientData clientData; /* Points to command's Command structure. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 |
*/
int
TclInvokeObjectCommand(clientData, interp, argc, argv)
ClientData clientData; /* Points to command's Command structure. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
register CONST char **argv; /* Argument strings. */
{
Command *cmdPtr = (Command *) clientData;
register Tcl_Obj *objPtr;
register int i;
int length, result;
/*
|
| ︙ | ︙ | |||
2497 2498 2499 2500 2501 2502 2503 |
*/
TclCleanupCommand(cmdPtr);
return 0;
}
static char *
CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
| | | | > > | 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 |
*/
TclCleanupCommand(cmdPtr);
return 0;
}
static char *
CallCommandTraces(iPtr, cmdPtr, oldName, newName, flags)
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 passed to trace procedures:
* indicates what's happening to command,
* plus other stuff like TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, and
* TCL_INTERP_DESTROYED. */
{
register CommandTrace *tracePtr;
ActiveCommandTrace active;
char *result;
Tcl_Obj *oldNamePtr = NULL;
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 not
* process any more delete traces
*/
if (cmdPtr->flags & TCL_TRACE_RENAME) {
|
| ︙ | ︙ | |||
2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 |
cmdPtr->flags |= CMD_TRACE_ACTIVE;
cmdPtr->refCount++;
result = NULL;
active.nextPtr = iPtr->activeCmdTracePtr;
iPtr->activeCmdTracePtr = &active;
active.cmdPtr = cmdPtr;
Tcl_Preserve((ClientData) iPtr);
for (tracePtr = cmdPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
cmdPtr->flags |= tracePtr->flags;
if (oldName == NULL) {
| > > > > > | | > > > > > > > > > > | 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 |
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;
if (!(tracePtr->flags & flags)) {
continue;
}
cmdPtr->flags |= tracePtr->flags;
if (oldName == NULL) {
TclNewObj(oldNamePtr);
Tcl_IncrRefCount(oldNamePtr);
Tcl_GetCommandFullName((Tcl_Interp *) iPtr,
(Tcl_Command) cmdPtr, oldNamePtr);
oldName = TclGetString(oldNamePtr);
}
Tcl_Preserve((ClientData) tracePtr);
(*tracePtr->traceProc)(tracePtr->clientData,
(Tcl_Interp *) iPtr, oldName, newName, flags);
cmdPtr->flags &= ~tracePtr->flags;
Tcl_Release((ClientData) tracePtr);
}
/*
* If a new object was created to hold the full oldName,
* free it now.
*/
if (oldNamePtr != NULL) {
TclDecrRefCount(oldNamePtr);
}
/*
* Restore the variable's flags, remove the record of our active
* traces, and then return.
*/
cmdPtr->flags &= ~CMD_TRACE_ACTIVE;
|
| ︙ | ︙ | |||
2854 2855 2856 2857 2858 2859 2860 |
* 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),
| | | 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 |
* 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;
}
/*
|
| ︙ | ︙ | |||
2892 2893 2894 2895 2896 2897 2898 |
TclEvalObjvInternal(interp, objc, objv, command, length, flags)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* command. Also used for error
* reporting. */
int objc; /* Number of words in command. */
Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
* the words that make up the command. */
| | | | < < > > > > > > > > | | | | | | | > > > > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | < < | | | < < < < | < > | | < | < > > | | < < | > | | | | < < < | < < < < < < < | | < < < < < < < < < < < | | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
TclEvalObjvInternal(interp, objc, objv, command, length, flags)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* command. Also used for error
* reporting. */
int objc; /* Number of words in command. */
Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
* the words that make up the command. */
CONST char *command; /* Points to the beginning of the string
* representation of the command; this
* is used for traces. If the string
* representation of the command is
* unknown, an empty string should be
* supplied. If it is NULL, no traces will
* be called. */
int length; /* Number of bytes in command; if -1, all
* characters up to the first null byte are
* used. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
* TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are
* currently supported. */
{
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
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.
*/
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_INVOKE) {
iPtr->varFramePtr = NULL;
}
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
iPtr->varFramePtr = savedVarFramePtr;
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 if (TclInterpReady(interp) == TCL_ERROR) {
code = TCL_ERROR;
} else {
iPtr->numLevels++;
code = TclEvalObjvInternal(interp, objc+1, newObjv, command, length, 0);
iPtr->numLevels--;
}
Tcl_DecrRefCount(newObjv[0]);
ckfree((char *) newObjv);
goto done;
}
/*
* Call trace procedures if needed.
*/
if ((checkTraces) && (command != NULL)) {
int cmdEpoch = cmdPtr->cmdEpoch;
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);
}
cmdPtr->refCount--;
if (cmdEpoch != cmdPtr->cmdEpoch) {
/* 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) {
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
}
code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
iPtr->varFramePtr = savedVarFramePtr;
}
if (Tcl_AsyncReady()) {
code = Tcl_AsyncInvoke(interp, code);
}
/*
* Call 'leave' command traces
*/
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
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);
}
}
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
* call to TraceExecutionProc.
*/
if (traceCode != TCL_OK) {
code = traceCode;
}
/*
* If the interpreter has a non-empty string result, the result
* object is either empty or stale because some procedure set
* interp->result directly. If so, move the string result to the
* result object, then reset the string result.
*/
|
| ︙ | ︙ | |||
3074 3075 3076 3077 3078 3079 3080 |
* command. Also used for error
* reporting. */
int objc; /* Number of words in command. */
Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
* the words that make up the command. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
| | | | < | 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 |
* command. Also used for error
* reporting. */
int objc; /* Number of words in command. */
Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
* the words that make up the command. */
int flags; /* Collection of OR-ed bits that control
* the evaluation of the script. Only
* TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE
* are currently supported. */
{
Interp *iPtr = (Interp *)interp;
Trace *tracePtr;
Tcl_DString cmdBuf;
char *cmdString = ""; /* A command string is only necessary for
* command traces or error logs; it will be
* generated to replace this default value if
* necessary. */
int cmdLen = 0; /* a non-zero value indicates that a command
* string was generated. */
int code = TCL_OK;
int i;
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->level == 0) || (iPtr->numLevels <= tracePtr->level)) {
/*
* The command may be needed for an execution trace. Generate a
* command string.
*/
Tcl_DStringInit(&cmdBuf);
for (i = 0; i < objc; i++) {
|
| ︙ | ︙ | |||
3132 3133 3134 3135 3136 3137 3138 |
if ((code != TCL_OK) && (code != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, code);
code = TCL_ERROR;
}
}
| | | 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 |
if ((code != TCL_OK) && (code != TCL_ERROR)
&& !allowExceptions) {
ProcessUnexpectedResult(interp, code);
code = TCL_ERROR;
}
}
if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) {
/*
* If there was an error, a command string will be needed for the
* error log: generate it now if it was not done previously.
*/
if (cmdLen == 0) {
|
| ︙ | ︙ | |||
3276 3277 3278 3279 3280 3281 3282 |
#ifdef TCL_MEM_DEBUG
# define MAX_VAR_CHARS 5
#else
# define MAX_VAR_CHARS 30
#endif
char nameBuffer[MAX_VAR_CHARS+1];
char *varName, *index;
| | | 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 |
#ifdef TCL_MEM_DEBUG
# define MAX_VAR_CHARS 5
#else
# define MAX_VAR_CHARS 30
#endif
char nameBuffer[MAX_VAR_CHARS+1];
char *varName, *index;
CONST char *p = NULL; /* Initialized to avoid compiler warning. */
int length, code;
/*
* The only tricky thing about this procedure is that it attempts to
* avoid object creation and string copying whenever possible. For
* example, if the value is just a nested command, then use the
* command's result object directly.
|
| ︙ | ︙ | |||
3484 3485 3486 3487 3488 3489 3490 |
*----------------------------------------------------------------------
*/
int
Tcl_EvalEx(interp, script, numBytes, flags)
Tcl_Interp *interp; /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
| | | | | 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 |
*----------------------------------------------------------------------
*/
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. */
{
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 i, code, 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);
/* For nested scripts, this variable will be set to point to the first
* char after the end of the script - needed only to compare pointers,
* nothing will be read nor written there.
*/
CONST char *onePast = NULL;
/*
* 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.
*/
|
| ︙ | ︙ | |||
3680 3681 3682 3683 3684 3685 3686 |
if (gotParse) {
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
Tcl_FreeParse(&parse);
if ((nested != 0) && (p > script)) {
| | | 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 |
if (gotParse) {
next = parse.commandStart + parse.commandSize;
bytesLeft -= next - p;
p = next;
Tcl_FreeParse(&parse);
if ((nested != 0) && (p > script)) {
CONST char *nextCmd = NULL; /* pointer to start of next command */
/*
* We get here in the special case where the TCL_BRACKET_TERM
* flag was set in the interpreter.
*
* At this point, we want to find the end of the script
* (either end of script or the closing ']').
|
| ︙ | ︙ | |||
3759 3760 3761 3762 3763 3764 3765 |
*----------------------------------------------------------------------
*/
int
Tcl_Eval(interp, string)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by previous call to Tcl_CreateInterp). */
| | < < | | 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 |
*----------------------------------------------------------------------
*/
int
Tcl_Eval(interp, string)
Tcl_Interp *interp; /* Token for command interpreter (returned
* by previous call to Tcl_CreateInterp). */
CONST char *string; /* Pointer to TCL command to execute. */
{
int code = Tcl_EvalEx(interp, string, -1, 0);
/*
* For backwards compatibility with old C code that predates the
* object system in Tcl 8.0, we have to mirror the object result
* back into the string result (some callers may expect it there).
*/
|
| ︙ | ︙ | |||
4269 4270 4271 4272 4273 4274 4275 |
*----------------------------------------------------------------------
*/
int
TclInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
| | | 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 |
*----------------------------------------------------------------------
*/
int
TclInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
register CONST char **argv; /* The arg strings; argv[0] is the name of
* the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN and
* TCL_INVOKE_NO_UNKNOWN. */
{
register Tcl_Obj *objPtr;
register int i;
|
| ︙ | ︙ | |||
4366 4367 4368 4369 4370 4371 4372 |
*----------------------------------------------------------------------
*/
int
TclGlobalInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
| | | 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 |
*----------------------------------------------------------------------
*/
int
TclGlobalInvoke(interp, argc, argv, flags)
Tcl_Interp *interp; /* Where to invoke the command. */
int argc; /* Count of args. */
register CONST char **argv; /* The arg strings; argv[0] is the name of
* the command to invoke. */
int flags; /* Combination of flags controlling the
* call: TCL_INVOKE_HIDDEN and
* TCL_INVOKE_NO_UNKNOWN. */
{
register Interp *iPtr = (Interp *) interp;
int result;
|
| ︙ | ︙ | |||
4837 4838 4839 4840 4841 4842 4843 |
Tcl_Interp *interp; /* Interpreter in which to create trace. */
int level; /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
* command. */
ClientData clientData; /* Arbitrary value word to pass to proc. */
{
| < | 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 |
Tcl_Interp *interp; /* Interpreter in which to create trace. */
int level; /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc; /* Procedure to call before executing each
* command. */
ClientData clientData; /* Arbitrary value word to pass to proc. */
{
StringTraceData* data;
data = (StringTraceData*) ckalloc( sizeof( *data ));
data->clientData = clientData;
data->proc = proc;
return Tcl_CreateObjTrace( interp, level, 0, StringTraceProc,
(ClientData) data, StringTraceDeleteProc );
}
|
| ︙ | ︙ | |||
4897 4898 4899 4900 4901 4902 4903 |
argv[objc] = 0;
/*
* Invoke the command procedure. Note that we cast away const-ness
* on two parameters for compatibility with legacy code; the code
* MUST NOT modify either command or argv.
*/
| | | < < | 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 |
argv[objc] = 0;
/*
* Invoke the command procedure. Note that we cast away const-ness
* on two parameters for compatibility with legacy code; the code
* MUST NOT modify either command or argv.
*/
( data->proc )( data->clientData, interp, level,
(char*) command, cmdPtr->proc, cmdPtr->clientData,
objc, argv );
ckfree( (char*) argv );
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringTraceDeleteProc --
*
|
| ︙ | ︙ | |||
4966 4967 4968 4969 4970 4971 4972 |
* Locate the trace entry in the interpreter's trace list,
* and remove it from the list.
*/
while ( (*tracePtr2) != NULL && (*tracePtr2) != tracePtr ) {
tracePtr2 = &((*tracePtr2)->nextPtr);
}
| | | | 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 |
* Locate the trace entry in the interpreter's trace list,
* and remove it from the list.
*/
while ( (*tracePtr2) != NULL && (*tracePtr2) != tracePtr ) {
tracePtr2 = &((*tracePtr2)->nextPtr);
}
if ( *tracePtr2 == NULL ) {
return;
}
(*tracePtr2) = (*tracePtr2)->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.
*/
|
| ︙ | ︙ | |||
5075 5076 5077 5078 5079 5080 5081 |
* 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) {
| | | | | | | | | | 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 |
* 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 */
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
Tcl_NewStringObj(interp->result, -1), TCL_GLOBAL_ONLY);
}
/*
* If the errorCode variable wasn't set by the code that generated
* the error, set it to "NONE".
*/
if (!(iPtr->flags & ERROR_CODE_SET)) {
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorCode, NULL,
Tcl_NewStringObj("NONE", -1), TCL_GLOBAL_ONLY);
}
}
/*
* Now append "message" to the end of errorInfo.
*/
if (length != 0) {
messagePtr = Tcl_NewStringObj(message, length);
Tcl_IncrRefCount(messagePtr);
Tcl_ObjSetVar2(interp, iPtr->execEnvPtr->errorInfo, NULL,
messagePtr, (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
}
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5209 5210 5211 5212 5213 5214 5215 |
*
---------------------------------------------------------------------------
*/
int
Tcl_GlobalEval(interp, command)
Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
| | | 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 |
*
---------------------------------------------------------------------------
*/
int
Tcl_GlobalEval(interp, command)
Tcl_Interp *interp; /* Interpreter in which to evaluate command. */
CONST char *command; /* Command to evaluate. */
{
register Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = NULL;
|
| ︙ | ︙ |
Changes to generic/tclCkalloc.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * 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. * * This code contributed by Karl Lehenbauer and Mark Diekhans * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * 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. * * This code contributed by Karl Lehenbauer and Mark Diekhans * * RCS: @(#) $Id: tclCkalloc.c,v 1.12.14.2 2002/08/20 20:25:25 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #define FALSE 0 #define TRUE 1 |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | static int ckallocInit = 0; /* * Prototypes for procedures defined in this file: */ static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, | | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 | static int ckallocInit = 0; /* * Prototypes for procedures defined in this file: */ static int CheckmemCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, CONST char *argv[])); static int MemoryCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, CONST char **argv)); static void ValidateMemory _ANSI_ARGS_(( struct mem_header *memHeaderP, CONST char *file, int line, int nukeGuards)); /* *---------------------------------------------------------------------- * |
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
Tcl_ValidateAllMemory (file, line);
result = (struct mem_header *) TclpAlloc((unsigned)size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
if (result == NULL) {
fflush(stdout);
TclDumpMemoryInfo(stderr);
| | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 |
Tcl_ValidateAllMemory (file, line);
result = (struct mem_header *) TclpAlloc((unsigned)size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
if (result == NULL) {
fflush(stdout);
TclDumpMemoryInfo(stderr);
panic("unable to alloc %ud bytes, %s line %d", size, file, line);
}
/*
* Fill in guard zones and size. Also initialize the contents of
* the block with bogus bytes to detect uses of initialized data.
* Link into allocated list.
*/
|
| ︙ | ︙ | |||
418 419 420 421 422 423 424 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing)
| | | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing)
fprintf(stderr,"ckalloc %lx %ud %s %d\n",
(long unsigned int) result->body, size, file, line);
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
fprintf(stderr,"reached malloc break limit (%d)\n",
total_mallocs);
|
| ︙ | ︙ | |||
503 504 505 506 507 508 509 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing)
| | | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing)
fprintf(stderr,"ckalloc %lx %ud %s %d\n",
(long unsigned int) result->body, size, file, line);
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
fprintf(stderr,"reached malloc break limit (%d)\n",
total_mallocs);
|
| ︙ | ︙ | |||
777 778 779 780 781 782 783 |
*/
/* ARGSUSED */
static int
MemoryCmd (clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
| | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 |
*/
/* ARGSUSED */
static int
MemoryCmd (clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
CONST char **argv;
{
CONST char *fileName;
Tcl_DString buffer;
int result;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
|
| ︙ | ︙ | |||
929 930 931 932 933 934 935 |
*/
static int
CheckmemCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter for evaluation. */
int argc; /* Number of arguments. */
| | | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 |
*/
static int
CheckmemCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter for evaluation. */
int argc; /* Number of arguments. */
CONST char *argv[]; /* String values of arguments. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" fileName\"", (char *) NULL);
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 |
* by returning NULL, so we have to check that the NULL we get is
* not in response to alloc(0).
*
* The ANSI spec actually says that systems either return NULL *or*
* a special pointer on failure, but we only check for NULL
*/
if ((result == NULL) && size) {
| | | | 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 |
* by returning NULL, so we have to check that the NULL we get is
* not in response to alloc(0).
*
* The ANSI spec actually says that systems either return NULL *or*
* a special pointer on failure, but we only check for NULL
*/
if ((result == NULL) && size) {
panic("unable to alloc %ud bytes", size);
}
return result;
}
char *
Tcl_DbCkalloc(size, file, line)
unsigned int size;
CONST char *file;
int line;
{
char *result;
result = (char *) TclpAlloc(size);
if ((result == NULL) && size) {
fflush(stdout);
panic("unable to alloc %ud bytes, %s line %d", size, file, line);
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1081 1082 1083 1084 1085 1086 1087 |
unsigned int size;
{
char *result;
result = TclpRealloc(ptr, size);
if ((result == NULL) && size) {
| | | | 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 |
unsigned int size;
{
char *result;
result = TclpRealloc(ptr, size);
if ((result == NULL) && size) {
panic("unable to realloc %ud bytes", size);
}
return result;
}
char *
Tcl_DbCkrealloc(ptr, size, file, line)
char *ptr;
unsigned int size;
CONST char *file;
int line;
{
char *result;
result = (char *) TclpRealloc(ptr, size);
if ((result == NULL) && size) {
fflush(stdout);
panic("unable to realloc %ud bytes, %s line %d", size, file, line);
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1228 1229 1230 1231 1232 1233 1234 |
*---------------------------------------------------------------------------
*/
void
TclFinalizeMemorySubsystem()
{
#ifdef TCL_MEM_DEBUG
| < > | 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 |
*---------------------------------------------------------------------------
*/
void
TclFinalizeMemorySubsystem()
{
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(tclMemDumpFileName);
} else if (onExitMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(onExitMemDumpFileName);
}
Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
TclpFree((char *) curTagPtr);
curTagPtr = NULL;
}
allocHead = NULL;
Tcl_MutexUnlock(ckallocMutexPtr);
#endif
#if USE_TCLALLOC
TclFinalizeAllocSubsystem();
#endif
}
|
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 | /* * 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.11.14.3 2002/08/20 20:25:25 das Exp $ */ #include "tcl.h" #include "tclInt.h" #include "tclPort.h" /* |
| ︙ | ︙ | |||
323 324 325 326 327 328 329 330 331 332 333 |
for (bufSize = 1, p = format; *p != '\0'; p++) {
if (*p == '%') {
bufSize += 40;
} else {
bufSize++;
}
}
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, bufSize);
Tcl_MutexLock(&clockMutex);
| > > | | > | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
for (bufSize = 1, p = format; *p != '\0'; p++) {
if (*p == '%') {
bufSize += 40;
} else {
bufSize++;
}
}
Tcl_DStringInit(&uniBuffer);
Tcl_UtfToExternalDString(NULL, format, -1, &uniBuffer);
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, bufSize);
Tcl_MutexLock(&clockMutex);
result = TclpStrftime(buffer.string, (unsigned int) bufSize,
Tcl_DStringValue(&uniBuffer), timeDataPtr, useGMT);
Tcl_MutexUnlock(&clockMutex);
Tcl_DStringFree(&uniBuffer);
#if !defined(HAVE_TM_ZONE) && !defined(WIN32)
if (useGMT) {
if (savedTZEnv != NULL) {
Tcl_SetVar2(interp, "env", "TZ", savedTZEnv, TCL_GLOBAL_ONLY);
ckfree(savedTZEnv);
} else {
|
| ︙ | ︙ |
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.16.4.3 2002/08/20 20:25:25 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #include <locale.h> /* |
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
* This list of constants should match the fileOption string array below.
*/
static CONST char *fileOptions[] = {
"atime", "attributes", "channels", "copy",
"delete",
"dirname", "executable", "exists", "extension",
| | | | | | 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 |
* This list of constants should match the fileOption string array below.
*/
static CONST char *fileOptions[] = {
"atime", "attributes", "channels", "copy",
"delete",
"dirname", "executable", "exists", "extension",
"isdirectory", "isfile", "join", "link",
"lstat", "mtime", "mkdir", "nativename",
"normalize", "owned",
"pathtype", "readable", "readlink", "rename",
"rootname", "separator", "size", "split",
"stat", "system",
"tail", "type", "volumes", "writable",
(char *) NULL
};
enum options {
FILE_ATIME, FILE_ATTRIBUTES, FILE_CHANNELS, FILE_COPY,
FILE_DELETE,
FILE_DIRNAME, FILE_EXECUTABLE, FILE_EXISTS, FILE_EXTENSION,
FILE_ISDIRECTORY, FILE_ISFILE, FILE_JOIN, FILE_LINK,
FILE_LSTAT, FILE_MTIME, FILE_MKDIR, FILE_NATIVENAME,
FILE_NORMALIZE, FILE_OWNED,
FILE_PATHTYPE, FILE_READABLE, FILE_READLINK, FILE_RENAME,
FILE_ROOTNAME, FILE_SEPARATOR, FILE_SIZE, FILE_SPLIT,
FILE_STAT, FILE_SYSTEM,
FILE_TAIL, FILE_TYPE, FILE_VOLUMES, FILE_WRITABLE
};
|
| ︙ | ︙ | |||
951 952 953 954 955 956 957 958 959 960 961 962 963 964 |
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 FILE_LSTAT: {
char *varName;
Tcl_StatBuf buf;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name varName");
return TCL_ERROR;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
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 FILE_LINK: {
Tcl_Obj *contents;
int index;
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"?-linktype? linkname ?target?");
return TCL_ERROR;
}
/* Index of the 'source' argument */
if (objc == 5) {
index = 3;
} else {
index = 2;
}
if (objc > 3) {
int linkAction;
if (objc == 5) {
/* We have a '-linktype' argument */
static CONST char *linkTypes[] = {
"-symbolic", "-hard", NULL
};
if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes,
"switch", 0, &linkAction) != TCL_OK) {
return TCL_ERROR;
}
if (linkAction == 0) {
linkAction = TCL_CREATE_SYMBOLIC_LINK;
} else {
linkAction = TCL_CREATE_HARD_LINK;
}
} else {
linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
}
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
/* Create link from source to target */
contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
if (contents == NULL) {
/*
* We handle two common error cases specially, and
* for all other errors, we use the standard posix
* error message.
*/
if (errno == EEXIST) {
Tcl_AppendResult(interp, "could not create new link \"",
Tcl_GetString(objv[index]),
"\": that path already exists", (char *) NULL);
} else if (errno == ENOENT) {
Tcl_AppendResult(interp, "could not create new link \"",
Tcl_GetString(objv[index]),
"\" since target \"",
Tcl_GetString(objv[index+1]),
"\" doesn't exist",
(char *) NULL);
} else {
Tcl_AppendResult(interp, "could not create new link \"",
Tcl_GetString(objv[index]), "\" pointing to \"",
Tcl_GetString(objv[index+1]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return TCL_ERROR;
}
} else {
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
/* Read link */
contents = Tcl_FSLink(objv[index], NULL, 0);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not read link \"",
Tcl_GetString(objv[index]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, contents);
if (objc == 3) {
/*
* If we are reading a link, we need to free this
* 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 FILE_LSTAT: {
char *varName;
Tcl_StatBuf buf;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name varName");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 |
goto only3Args;
}
if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
return TCL_ERROR;
}
| | | 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 |
goto only3Args;
}
if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
return TCL_ERROR;
}
contents = Tcl_FSLink(objv[2], NULL, 0);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not readlink \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ |
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.35.2.3 2002/08/20 20:25:25 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclRegexp.h" /* |
| ︙ | ︙ | |||
1383 1384 1385 1386 1387 1388 1389 |
localVarTablePtr = iPtr->varFramePtr->varTablePtr;
for (i = 0; i < localVarCt; i++) {
/*
* Skip nameless (temporary) variables and undefined variables
*/
| | > | 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 |
localVarTablePtr = iPtr->varFramePtr->varTablePtr;
for (i = 0; i < localVarCt; i++) {
/*
* Skip nameless (temporary) variables and undefined variables
*/
if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr)
&& (includeLinks || !TclIsVarLink(varPtr))) {
varName = varPtr->name;
if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(varName, -1));
}
}
varPtr++;
|
| ︙ | ︙ |
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 | * 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.46.2.3 2002/08/20 20:25:25 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclRegexp.h" /* |
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | * 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; /* | | > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > | | | | 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 |
* 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;
/*
* Structure used to hold information about command traces:
*/
typedef struct {
int flags; /* Operations for which Tcl command is
* to be invoked. */
size_t length; /* Number of non-NULL chars. in command. */
Tcl_Trace stepTrace; /* Used for execution traces, when tracing
* inside the given command */
int startLevel; /* Used for bookkeeping with execution traces */
int curFlags; /* Trace flags for the current command */
int curCode; /* Return code for the current 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. */
} TraceCommandInfo;
/*
* Used by command execution traces. Note that we assume in the code
* that the first two defines are exactly 4 times the
* 'TCL_TRACE_ENTER_EXEC' and 'TCL_TRACE_LEAVE_EXEC' constants.
*
* TCL_TRACE_ENTER_DURING_EXEC - Trace each command inside the command
* currently being traced, before execution.
* TCL_TRACE_LEAVE_DURING_EXEC - Trace each command inside the command
* currently being traced, after execution.
* TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags.
* TCL_TRACE_EXEC_IN_PROGRESS - The callback procedure on this trace
* is currently executing. Therefore we
* don't let further traces execute.
* TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly
* by the command being traced, not because
* of an internal trace.
* The flags 'TCL_TRACE_DESTROYED' and 'TCL_INTERP_DESTROYED' may also
* be used in command execution traces.
*/
#define TCL_TRACE_ENTER_DURING_EXEC 4
#define TCL_TRACE_LEAVE_DURING_EXEC 8
#define TCL_TRACE_ANY_EXEC 15
#define TCL_TRACE_EXEC_IN_PROGRESS 0x10
#define TCL_TRACE_EXEC_DIRECT 0x20
/*
* Forward declarations for procedures defined in this file:
*/
typedef int (Tcl_TraceTypeObjCmd) _ANSI_ARGS_((Tcl_Interp *interp,
int optionIndex, int objc, Tcl_Obj *CONST objv[]));
Tcl_TraceTypeObjCmd TclTraceVariableObjCmd;
Tcl_TraceTypeObjCmd TclTraceCommandObjCmd;
Tcl_TraceTypeObjCmd TclTraceExecutionObjCmd;
/*
* Each subcommand has a number of 'types' to which it can apply.
* Currently 'execution', 'command' and 'variable' are the only
* types supported. These three arrays MUST be kept in sync!
* In the future we may provide an API to add to the list of
* supported trace types.
*/
static CONST char *traceTypeOptions[] = {
"execution", "command", "variable", (char*) NULL
};
static Tcl_TraceTypeObjCmd* traceSubCmds[] = {
TclTraceExecutionObjCmd,
TclTraceCommandObjCmd,
TclTraceVariableObjCmd,
};
/*
* Declarations for local procedures to this file:
*/
static int CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
Trace *tracePtr, Command *cmdPtr,
CONST char *command, int numChars,
int objc, Tcl_Obj *CONST objv[]));
static char * TraceVarProc _ANSI_ARGS_((ClientData clientData,
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.
|
| ︙ | ︙ | |||
432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 |
}
}
/*
* Set the interpreter's object result to an integer object
* with value 1 if -all wasn't specified, otherwise it's all-1
* (the number of times through the while - 1).
*/
if (!doinline) {
Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
| > > > | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 |
}
}
/*
* Set the interpreter's object result to an integer object
* with value 1 if -all wasn't specified, otherwise it's all-1
* (the number of times through the while - 1).
* Get the resultPtr again as the Tcl_ObjSetVar2 above may have
* cause the result to change. [Patch #558324] (watson).
*/
if (!doinline) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_SetIntObj(resultPtr, (all ? all-1 : 1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2809 2810 2811 2812 2813 2814 2815 | * Tcl_TraceObjCmd -- * * This procedure is invoked to process the "trace" Tcl command. * See the user documentation for details on what it does. * * Standard syntax as of Tcl 8.4 is * | | | 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 |
* Tcl_TraceObjCmd --
*
* This procedure is invoked to process the "trace" Tcl command.
* See the user documentation for details on what it does.
*
* Standard syntax as of Tcl 8.4 is
*
* trace {add|info|remove} {command|variable} name ops cmd
*
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
|
| ︙ | ︙ | |||
2833 2834 2835 2836 2837 2838 2839 |
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int optionIndex, commandLength;
char *name, *flagOps, *command, *p;
size_t length;
/* Main sub commands to 'trace' */
static CONST char *traceOptions[] = {
| | | | | 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 |
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int optionIndex, commandLength;
char *name, *flagOps, *command, *p;
size_t length;
/* Main sub commands to 'trace' */
static CONST char *traceOptions[] = {
"add", "info", "remove",
#ifndef TCL_REMOVE_OBSOLETE_TRACES
"variable", "vdelete", "vinfo",
#endif
(char *) NULL
};
/* 'OLD' options are pre-Tcl-8.4 style */
enum traceOptions {
TRACE_ADD, TRACE_INFO, TRACE_REMOVE,
#ifndef TCL_REMOVE_OBSOLETE_TRACES
TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO
#endif
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions,
"option", 0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE:
case TRACE_INFO: {
/*
* All sub commands of trace add/remove must take at least
* one more argument. Beyond that we let the subcommand itself
* control the argument structure.
*/
int typeIndex;
if (objc < 3) {
|
| ︙ | ︙ | |||
2972 2973 2974 2975 2976 2977 2978 |
tvarPtr = (TraceVarInfo *) clientData;
if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
| | | 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 |
tvarPtr = (TraceVarInfo *) clientData;
if ((tvarPtr->length == length) && (tvarPtr->flags == flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
break;
}
}
break;
}
case TRACE_OLD_VINFO: {
ClientData clientData;
|
| ︙ | ︙ | |||
3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 |
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclTraceCommandObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | 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 |
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclTraceExecutionObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
* [trace {add|remove|info} execution ...] subcommands.
* See the user documentation for details on what these do.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depends on the operation (add, remove, or info) being performed;
* may add or remove command traces on a command.
*
*----------------------------------------------------------------------
*/
int
TclTraceExecutionObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int optionIndex; /* Add, info or remove */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "enter", "leave",
"enterstep", "leavestep", (char *) NULL };
enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE,
TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
int i, listLen, result;
Tcl_Obj **elemPtrs;
if (objc != 6) {
Tcl_WrongNumArgs(interp, 3, objv, "name opList execution");
return TCL_ERROR;
}
/*
* Make sure the ops argument is a list object; get its length and
* a pointer to its array of element pointers.
*/
result = Tcl_ListObjGetElements(interp, objv[4], &listLen,
&elemPtrs);
if (result != TCL_OK) {
return result;
}
if (listLen == 0) {
Tcl_SetResult(interp, "bad operation list \"\": must be "
"one or more of enter, leave, enterstep, or leavestep", TCL_STATIC);
return TCL_ERROR;
}
for (i = 0; i < listLen; i++) {
if (Tcl_GetIndexFromObj(interp, elemPtrs[i], opStrings,
"operation", TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum operations) index) {
case TRACE_EXEC_ENTER:
flags |= TCL_TRACE_ENTER_EXEC;
break;
case TRACE_EXEC_LEAVE:
flags |= TCL_TRACE_LEAVE_EXEC;
break;
case TRACE_EXEC_ENTER_STEP:
flags |= TCL_TRACE_ENTER_DURING_EXEC;
break;
case TRACE_EXEC_LEAVE_STEP:
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = Tcl_GetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr;
tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->length = length;
flags |= TCL_TRACE_DELETE;
if (flags & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
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;
}
} else {
/*
* Search through all of our traces on this command to
* see if there's one with the given command. If so, then
* delete the first one that matches.
*/
TraceCommandInfo *tcmdPtr;
ClientData clientData;
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != 0) {
tcmdPtr = (TraceCommandInfo *) clientData;
/*
* In checking the 'flags' field we must remove any extraneous
* flags which may have been temporarily added by various pieces
* of the trace mechanism.
*/
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 & (TRACE_EXEC_ENTER_STEP | TRACE_EXEC_LEAVE_STEP)) {
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;
}
/* Postpone deletion */
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
tcmdPtr->flags = 0;
} else {
Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_GetObjResult(interp);
clientData = 0;
name = Tcl_GetString(objv[3]);
while ((clientData = Tcl_CommandTraceInfo(interp, name, 0,
TraceCommandProc, clientData)) != 0) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
eachTraceObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
/*
* 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);
if (tcmdPtr->flags & TCL_TRACE_ENTER_EXEC) {
Tcl_ListObjAppendElement(NULL, elemObjPtr,
Tcl_NewStringObj("enter",6));
}
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",10));
}
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
elemObjPtr = Tcl_NewStringObj(tcmdPtr->command, -1);
Tcl_ListObjAppendElement(NULL, eachTraceObjPtr, elemObjPtr);
Tcl_ListObjAppendElement(interp, resultListPtr,
eachTraceObjPtr);
}
Tcl_SetObjResult(interp, resultListPtr);
break;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclTraceCommandObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
* [trace {add|info|remove} command ...] subcommands.
* See the user documentation for details on what these do.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depends on the operation (add, remove, or info) being performed;
* may add or remove command traces on a command.
*
*----------------------------------------------------------------------
*/
int
TclTraceCommandObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int optionIndex; /* Add, info or remove */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "delete", "rename", (char *) NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
int flags = 0;
|
| ︙ | ︙ | |||
3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 |
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr;
tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ length + 1));
tcmdPtr->flags = flags;
tcmdPtr->length = length;
flags |= TCL_TRACE_DELETE;
strcpy(tcmdPtr->command, command);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
(ClientData) tcmdPtr) != TCL_OK) {
ckfree((char *) tcmdPtr);
| > > | 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 |
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr;
tcmdPtr = (TraceCommandInfo *) ckalloc((unsigned)
(sizeof(TraceCommandInfo) - sizeof(tcmdPtr->command)
+ length + 1));
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->length = length;
flags |= TCL_TRACE_DELETE;
strcpy(tcmdPtr->command, command);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
(ClientData) tcmdPtr) != TCL_OK) {
ckfree((char *) tcmdPtr);
|
| ︙ | ︙ | |||
3159 3160 3161 3162 3163 3164 3165 | ckfree((char *) tcmdPtr); break; } } } break; } | | | 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 |
ckfree((char *) tcmdPtr);
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3214 3215 3216 3217 3218 3219 3220 | /* *---------------------------------------------------------------------- * * TclTraceVariableObjCmd -- * * Helper function for Tcl_TraceObjCmd; implements the | | | | | | 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 |
/*
*----------------------------------------------------------------------
*
* TclTraceVariableObjCmd --
*
* Helper function for Tcl_TraceObjCmd; implements the
* [trace {add|info|remove} variable ...] subcommands.
* See the user documentation for details on what these do.
*
* Results:
* Standard Tcl result.
*
* Side effects:
* Depends on the operation (add, remove, or info) being performed;
* may add or remove variable traces on a variable.
*
*----------------------------------------------------------------------
*/
int
TclTraceVariableObjCmd(interp, optionIndex, objc, objv)
Tcl_Interp *interp; /* Current interpreter. */
int optionIndex; /* Add, info or remove */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
int commandLength, index;
char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static CONST char *opStrings[] = { "array", "read", "unset", "write",
(char *) NULL };
enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET,
TRACE_VAR_WRITE };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
|
| ︙ | ︙ | |||
3326 3327 3328 3329 3330 3331 3332 |
if ((tvarPtr->length == length)
&& (tvarPtr->flags == flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
| | | | 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 |
if ((tvarPtr->length == length)
&& (tvarPtr->flags == flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr, *eachTraceObjPtr, *elemObjPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
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 |
/*
*----------------------------------------------------------------------
*
* Tcl_TraceCommand --
*
* Arrange for rename/deletes to a command to cause a
* procedure to be invoked, which can monitor the operations.
*
* Results:
* A standard Tcl return value.
*
* Side effects:
* A trace is set up on the command given by cmdName, such that
* future changes to the command will be intermediated by
* proc. See the manual entry for complete details on the calling
* sequence for proc.
*
*----------------------------------------------------------------------
*/
int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which command is
* to be traced. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed collection of bits, including any
| > > > | > | > > > > | 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 |
/*
*----------------------------------------------------------------------
*
* Tcl_TraceCommand --
*
* Arrange for rename/deletes to a command to cause a
* procedure to be invoked, which can monitor the operations.
*
* Also optionally arrange for execution of that command
* to cause a procedure to be invoked.
*
* Results:
* A standard Tcl return value.
*
* Side effects:
* A trace is set up on the command given by cmdName, such that
* future changes to the command will be intermediated by
* proc. See the manual entry for complete details on the calling
* sequence for proc.
*
*----------------------------------------------------------------------
*/
int
Tcl_TraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which command is
* to be traced. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
* and any of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc; /* Procedure to call when specified ops are
* invoked upon varName. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
register CommandTrace *tracePtr;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return TCL_ERROR;
}
/*
* Set up trace information.
*/
tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE
| TCL_TRACE_ANY_EXEC);
tracePtr->nextPtr = cmdPtr->tracePtr;
cmdPtr->tracePtr = tracePtr;
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UntraceCommand --
|
| ︙ | ︙ | |||
3535 3536 3537 3538 3539 3540 3541 |
*/
void
Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing command. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed collection of bits, including any
| | > > | | > | > > > | | > | > > > > > > > > > > > > > > | > | 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 |
*/
void
Tcl_UntraceCommand(interp, cmdName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing command. */
CONST char *cmdName; /* Name of command. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_RENAME, TCL_TRACE_DELETE,
* and any of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc; /* Procedure assocated with trace. */
ClientData clientData; /* Arbitrary argument to pass to proc. */
{
register CommandTrace *tracePtr;
CommandTrace *prevPtr;
Command *cmdPtr;
Interp *iPtr = (Interp *) interp;
ActiveCommandTrace *activePtr;
int hasExecTraces = 0;
cmdPtr = (Command*)Tcl_FindCommand(interp, cmdName,
NULL, TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return;
}
flags &= (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
return;
}
if ((tracePtr->traceProc == proc) && ((tracePtr->flags & (TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC)) == flags)
&& (tracePtr->clientData == clientData)) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
hasExecTraces = 1;
}
break;
}
}
/*
* 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 CallCommandTraces.
*/
for (activePtr = iPtr->activeCmdTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
if (prevPtr == NULL) {
cmdPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
tracePtr->flags = 0;
Tcl_EventuallyFree((int*)tracePtr, TCL_DYNAMIC);
if (hasExecTraces) {
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
return;
}
}
/*
* None of the remaining traces on this command are execution
* traces. We therefore remove this flag:
*/
cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
}
}
/*
*----------------------------------------------------------------------
*
* TraceCommandProc --
*
* This procedure is called to handle command changes that have
* been traced using the "trace" command, when using the
* 'rename' or 'delete' options.
*
* Results:
* None.
*
* Side effects:
* Depends on the command associated with the trace.
*
|
| ︙ | ︙ | |||
3616 3617 3618 3619 3620 3621 3622 |
int flags; /* OR-ed bits giving operation and other
* information. */
{
Tcl_SavedResult state;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
int code;
Tcl_DString cmd;
| | > > | 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 |
int flags; /* OR-ed bits giving operation and other
* information. */
{
Tcl_SavedResult state;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *) clientData;
int code;
Tcl_DString cmd;
Tcl_Preserve((ClientData) tcmdPtr);
if ((tcmdPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
/*
* Generate a command to execute by appending list elements
* for the old and new command name and the operation.
*/
Tcl_DStringInit(&cmd);
|
| ︙ | ︙ | |||
3662 3663 3664 3665 3666 3667 3668 |
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)) {
| > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
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;
}
/* Postpone deletion, until exec trace returns */
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
tcmdPtr->flags = 0;
} else {
Tcl_EventuallyFree((ClientData) tcmdPtr, TCL_DYNAMIC);
}
}
Tcl_Release((ClientData) tcmdPtr);
return;
}
/*
*----------------------------------------------------------------------
*
* TclCheckExecutionTraces --
*
* Checks on all current command execution traces, and invokes
* procedures which have been registered. This procedure can be
* used by other code which performs execution to unify the
* tracing system, so that execution traces will function for that
* other code.
*
* For instance extensions like [incr Tcl] which use their
* own execution technique can make use of Tcl's tracing.
*
* This procedure is called by 'TclEvalObjvInternal'
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR, etc.
*
* Side effects:
* Those side effects made by any trace procedures called.
*
*----------------------------------------------------------------------
*/
int
TclCheckExecutionTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
CONST char *command; /* Pointer to beginning of the current
* command string. */
int numChars; /* The number of characters in 'command'
* which are part of the command string. */
Command *cmdPtr; /* Points to command's Command struct. */
int code; /* The current result code. */
int traceFlags; /* Current tracing situation. */
int objc; /* Number of arguments for the command. */
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
CommandTrace *tracePtr, *lastTracePtr;
ActiveCommandTrace active;
int curLevel;
int traceCode = TCL_OK;
TraceCommandInfo* tcmdPtr;
if (command == NULL || cmdPtr->tracePtr == NULL) {
return(traceCode);
}
curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
active.nextPtr = iPtr->activeCmdTracePtr;
iPtr->activeCmdTracePtr = &active;
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;
}
tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
if (tcmdPtr->flags != 0) {
tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
tcmdPtr->curCode = code;
traceCode = TraceExecutionProc((ClientData)tcmdPtr, interp,
curLevel, command, (Tcl_Command)cmdPtr, objc, objv);
}
lastTracePtr = tracePtr;
}
iPtr->activeCmdTracePtr = active.nextPtr;
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* TclCheckInterpTraces --
*
* Checks on all current traces, and invokes procedures which
* have been registered. This procedure can be used by other
* code which performs execution to unify the tracing system.
* For instance extensions like [incr Tcl] which use their
* own execution technique can make use of Tcl's tracing.
*
* This procedure is called by 'TclEvalObjvInternal'
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR, etc.
*
* Side effects:
* Those side effects made by any trace procedures called.
*
*----------------------------------------------------------------------
*/
int
TclCheckInterpTraces(interp, command, numChars, cmdPtr, code, traceFlags, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
CONST char *command; /* Pointer to beginning of the current
* command string. */
int numChars; /* The number of characters in 'command'
* which are part of the command string. */
Command *cmdPtr; /* Points to command's Command struct. */
int code; /* The current result code. */
int traceFlags; /* Current tracing situation. */
int objc; /* Number of arguments for the command. */
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;
TraceCommandInfo* tcmdPtr;
if (command == NULL || iPtr->tracePtr == NULL ||
(iPtr->flags & INTERP_TRACE_IN_PROGRESS)) {
return(traceCode);
}
curLevel = ((iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level);
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.nextTracePtr = NULL;
tracePtr = iPtr->tracePtr;
while (tracePtr->nextPtr != lastTracePtr) {
active.nextTracePtr = tracePtr;
tracePtr = tracePtr->nextPtr;
}
} else {
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->level > 0 && curLevel > tracePtr->level) {
continue;
}
if (!(tracePtr->flags & TCL_TRACE_EXEC_IN_PROGRESS)) {
tracePtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
if ((tracePtr->flags != TCL_TRACE_EXEC_IN_PROGRESS) &&
((tracePtr->flags & traceFlags) != 0)) {
tcmdPtr = (TraceCommandInfo*)tracePtr->clientData;
tcmdPtr->curFlags = traceFlags;
tcmdPtr->curCode = code;
traceCode = (tracePtr->proc)((ClientData)tcmdPtr,
(Tcl_Interp*)interp,
curLevel, command,
(Tcl_Command)cmdPtr,
objc, objv);
} else {
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;
}
lastTracePtr = tracePtr;
}
iPtr->activeInterpTracePtr = active.nextPtr;
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* CallTraceProcedure --
*
* Invokes a trace procedure registered with an interpreter. These
* procedures trace command execution. Currently this trace procedure
* is called with the address of the string-based Tcl_CmdProc for the
* command, not the Tcl_ObjCmdProc.
*
* Results:
* None.
*
* Side effects:
* Those side effects made by the trace procedure.
*
*----------------------------------------------------------------------
*/
static int
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
register Trace *tracePtr; /* Describes the trace procedure to call. */
Command *cmdPtr; /* Points to command's Command struct. */
CONST char *command; /* Points to the first character of the
* command's source before substitutions. */
int numChars; /* The number of characters in the
* command's source. */
register int objc; /* Number of arguments for the command. */
Tcl_Obj *CONST objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
char *commandCopy;
int traceCode;
/*
* Copy the command characters into a new string.
*/
commandCopy = (char *) ckalloc((unsigned) (numChars + 1));
memcpy((VOID *) commandCopy, (VOID *) command, (size_t) numChars);
commandCopy[numChars] = '\0';
/*
* Call the trace procedure then free allocated storage.
*/
traceCode = (tracePtr->proc)( tracePtr->clientData, (Tcl_Interp*) iPtr,
iPtr->numLevels, commandCopy,
(Tcl_Command) cmdPtr, objc, objv );
ckfree((char *) commandCopy);
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* TraceExecutionProc --
*
* This procedure is invoked whenever code relevant to a
* 'trace execution' command is executed. It is called in one
* of two ways in Tcl's core:
*
* (i) by the TclCheckExecutionTraces, when an execution trace has been
* triggered.
* (ii) by TclCheckInterpTraces, when a prior execution trace has
* created a trace of the internals of a procedure, passing in
* this procedure as the one to be called.
*
* Results:
* The return value is a standard Tcl completion code such as
* TCL_OK or TCL_ERROR, etc.
*
* Side effects:
* May invoke an arbitrary Tcl procedure, and may create or
* delete an interpreter-wide trace.
*
*----------------------------------------------------------------------
*/
int
TraceExecutionProc(ClientData clientData, Tcl_Interp *interp,
int level, CONST char* command, Tcl_Command cmdInfo,
int objc, struct Tcl_Obj *CONST objv[]) {
int call = 0;
Interp *iPtr = (Interp *) interp;
TraceCommandInfo* tcmdPtr = (TraceCommandInfo*)clientData;
int flags = tcmdPtr->curFlags;
int code = tcmdPtr->curCode;
int traceCode = TCL_OK;
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
* 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 (!(flags & TCL_INTERP_DESTROYED)) {
/*
* 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, we remove it
*/
if (flags & TCL_TRACE_LEAVE_EXEC) {
if ((tcmdPtr->stepTrace != NULL) && (level == tcmdPtr->startLevel)) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
}
}
/*
* Second, create the tcl callback, if required.
*/
if (call) {
Tcl_SavedResult state;
Tcl_DString cmd;
Tcl_DString sub;
int i;
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;
int len;
str = Tcl_GetStringFromObj(objv[i],&len);
Tcl_DStringAppendElement(&sub, str);
}
Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
Tcl_DStringFree(&sub);
if (flags & TCL_TRACE_ENTER_EXEC) {
/* Append trace operation */
if (flags & TCL_TRACE_EXEC_DIRECT) {
Tcl_DStringAppendElement(&cmd, "enter");
} else {
Tcl_DStringAppendElement(&cmd, "enterstep");
}
} else if (flags & TCL_TRACE_LEAVE_EXEC) {
Tcl_Obj* resultCode;
char* resultCodeStr;
/* Append result code */
resultCode = Tcl_NewIntObj(code);
resultCodeStr = Tcl_GetString(resultCode);
Tcl_DStringAppendElement(&cmd, resultCodeStr);
Tcl_DecrRefCount(resultCode);
/* Append result string */
Tcl_DStringAppendElement(&cmd, Tcl_GetStringResult(interp));
/* Append trace operation */
if (flags & TCL_TRACE_EXEC_DIRECT) {
Tcl_DStringAppendElement(&cmd, "leave");
} else {
Tcl_DStringAppendElement(&cmd, "leavestep");
}
} else {
panic("TraceExecutionProc: bad flag combination");
}
/*
* Execute the command. Save the interp's result used for
* the command. We discard any object result the command returns.
*/
Tcl_SaveResult(interp, &state);
tcmdPtr->flags |= TCL_TRACE_EXEC_IN_PROGRESS;
iPtr->flags |= INTERP_TRACE_IN_PROGRESS;
Tcl_Preserve((ClientData)tcmdPtr);
/*
* 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;
iPtr->flags &= ~INTERP_TRACE_IN_PROGRESS;
if (tcmdPtr->flags == 0) {
flags |= TCL_TRACE_DESTROYED;
}
if (traceCode == TCL_OK) {
/* Restore result if trace execution was successful */
Tcl_RestoreResult(interp, &state);
}
Tcl_DStringFree(&cmd);
}
/*
* Third, create an interpreter trace, if we need one for
* subsequent internal execution traces.
*/
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC | TCL_TRACE_LEAVE_DURING_EXEC))) {
tcmdPtr->startLevel = level;
tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
(tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
TraceExecutionProc, (ClientData)tcmdPtr, NULL);
}
}
if (flags & TCL_TRACE_DESTROYED) {
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
}
Tcl_EventuallyFree((ClientData)tcmdPtr, TCL_DYNAMIC);
}
if (call) {
Tcl_Release((ClientData)tcmdPtr);
}
return(traceCode);
}
/*
*----------------------------------------------------------------------
*
* TraceVarProc --
*
* This procedure is called to handle variable accesses that have
|
| ︙ | ︙ | |||
3690 3691 3692 3693 3694 3695 3696 |
*/
/* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Information about the variable trace. */
Tcl_Interp *interp; /* Interpreter containing variable. */
| | > > > > > > > > > > | 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 |
*/
/* ARGSUSED */
static char *
TraceVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Information about the variable trace. */
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *name1; /* Name of variable or array. */
CONST char *name2; /* Name of element within array; NULL means
* 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;
Tcl_DString cmd;
/*
* We might call Tcl_Eval() below, and that might evaluate
* [trace vdelete] which might try to free tvarPtr. We want
* to use tvarPtr until the end of this function, so we use
* Tcl_Preserve() and Tcl_Release() to be sure it is not
* freed while we still need it.
*/
Tcl_Preserve((ClientData) tvarPtr);
result = NULL;
if ((tvarPtr->flags & flags) && !(flags & TCL_INTERP_DESTROYED)) {
if (tvarPtr->length != (size_t) 0) {
/*
* Generate a command to execute by appending list elements
* for the two variable names and the operation.
*/
|
| ︙ | ︙ | |||
3774 3775 3776 3777 3778 3779 3780 |
if (flags & TCL_TRACE_DESTROYED) {
if (result != NULL) {
register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
Tcl_DecrRefCount(errMsgObj);
result = NULL;
}
| | > | 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 |
if (flags & TCL_TRACE_DESTROYED) {
if (result != NULL) {
register Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
Tcl_DecrRefCount(errMsgObj);
result = NULL;
}
Tcl_EventuallyFree((ClientData) tvarPtr, TCL_DYNAMIC);
}
Tcl_Release((ClientData) tvarPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_WhileObjCmd --
|
| ︙ | ︙ |
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 |
/*
* 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.14.4.3 2002/08/20 20:25:25 das Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* Prototypes for procedures defined later in this file:
|
| ︙ | ︙ | |||
119 120 121 122 123 124 125 |
* 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) {
| | | | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
* 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;
}
}
|
| ︙ | ︙ | |||
237 238 239 240 241 242 243 |
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. */
{
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *nameTokenPtr;
| | < | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
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. */
{
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;
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
cmdTokenPtr->numComponents, envPtr);
startOffset = (envPtr->codeNext - envPtr->codeStart);
TclEmitOpcode(INST_EVAL_STK, envPtr);
}
envPtr->exceptArrayPtr[range].codeOffset = startOffset;
if (code != TCL_OK) {
| | < < < < | < | 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 |
cmdTokenPtr->numComponents, envPtr);
startOffset = (envPtr->codeNext - envPtr->codeStart);
TclEmitOpcode(INST_EVAL_STK, envPtr);
}
envPtr->exceptArrayPtr[range].codeOffset = startOffset;
if (code != TCL_OK) {
code = TCL_OUT_LINE_COMPILE;
goto done;
}
envPtr->exceptArrayPtr[range].numCodeBytes =
(envPtr->codeNext - envPtr->codeStart) - startOffset;
/*
* The "no errors" epilogue code: store the body's result into the
* variable (if any), push "0" (TCL_OK) as the catch's "no error"
* result, and jump around the "error case" code.
*/
if (localIndex != -1) {
if (localIndex <= 255) {
TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
} else {
TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
}
}
TclEmitOpcode(INST_POP, envPtr);
TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
/*
* The "error case" code: store the body's result into the variable (if
* any), then push the error result code. The initial PC offset here is
* the catch's error target.
*/
|
| ︙ | ︙ | |||
670 671 672 673 674 675 676 |
(envPtr->codeNext - envPtr->codeStart);
/*
* The for command's result is an empty string.
*/
envPtr->currStackDepth = savedStackDepth;
| | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
(envPtr->codeNext - envPtr->codeStart);
/*
* The for command's result is an empty string.
*/
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
code = TCL_OK;
done:
envPtr->exceptDepth--;
return code;
}
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 | * should be compiled "out of line" by emitting code to invoke its * command procedure at runtime. * * Side effects: * Instructions are added to envPtr to execute the "foreach" command * at runtime. * | | < < < | 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 |
* should be compiled "out of line" by emitting code to invoke its
* command procedure at runtime.
*
* Side effects:
* Instructions are added to envPtr to execute the "foreach" command
* at runtime.
*
n*----------------------------------------------------------------------
*/
int
TclCompileForeachCmd(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. */
{
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
int firstValueTemp; /* Index of the first temp var in the frame
* used to point to a value list. */
int loopCtTemp; /* Index of temp var holding the loop's
* iteration count. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
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
*/
|
| ︙ | ︙ | |||
776 777 778 779 780 781 782 |
/*
* Allocate storage for the varcList and varvList arrays if necessary.
*/
numLists = (numWords - 2)/2;
if (numLists > STATIC_VAR_LIST_SIZE) {
varcList = (int *) ckalloc(numLists * sizeof(int));
| | | 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 |
/*
* Allocate storage for the varcList and varvList arrays if necessary.
*/
numLists = (numWords - 2)/2;
if (numLists > STATIC_VAR_LIST_SIZE) {
varcList = (int *) ckalloc(numLists * sizeof(int));
varvList = (CONST char ***) ckalloc(numLists * sizeof(CONST char **));
}
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
varcList[loopIndex] = 0;
varvList[loopIndex] = NULL;
}
/*
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr += (tokenPtr->numComponents + 1)) {
if (i%2 == 1) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
code = TCL_OUT_LINE_COMPILE;
goto done;
| > > > | | < < | < < < < | | | | | | | | < | | | | | | > | 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 |
for (i = 0, tokenPtr = parsePtr->tokenPtr;
i < numWords-1;
i++, tokenPtr += (tokenPtr->numComponents + 1)) {
if (i%2 == 1) {
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
code = TCL_OUT_LINE_COMPILE;
goto done;
} else {
/* Lots of copying going on here. Need a ListObj wizard
* to show a better way. */
Tcl_DString varList;
Tcl_DStringInit(&varList);
Tcl_DStringAppend(&varList, tokenPtr[1].start,
tokenPtr[1].size);
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;
}
}
}
loopIndex++;
}
}
/*
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 |
(envPtr->codeNext - envPtr->codeStart);
/*
* The foreach command's result is an empty string.
*/
envPtr->currStackDepth = savedStackDepth;
| | | | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 |
(envPtr->codeNext - envPtr->codeStart);
/*
* The foreach command's result is an empty string.
*/
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
envPtr->currStackDepth = savedStackDepth + 1;
done:
for (loopIndex = 0; loopIndex < numLists; loopIndex++) {
if (varvList[loopIndex] != (CONST char **) NULL) {
ckfree((char *) varvList[loopIndex]);
}
}
if (varcList != varcListStaticSpace) {
ckfree((char *) varcList);
ckfree((char *) varvList);
}
envPtr->exceptDepth--;
return code;
|
| ︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 |
/* Used to fix the jump after each "then"
* body to the end of the "if" when that PC
* is determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpDist, jumpFalseDist;
int jumpIndex = 0; /* avoid compiler warning. */
int numWords, wordIdx, numBytes, j, code;
| | < | 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
/* Used to fix the jump after each "then"
* body to the end of the "if" when that PC
* is determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpDist, jumpFalseDist;
int jumpIndex = 0; /* avoid compiler warning. */
int numWords, wordIdx, numBytes, j, code;
CONST char *word;
char buffer[100];
int savedStackDepth = envPtr->currStackDepth;
/* 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]
|
| ︙ | ︙ | |||
1227 1228 1229 1230 1231 1232 1233 |
if (realCond) {
/*
* Find out if the condition is a constant.
*/
| | | | < < < < < < < | < < | | < < | 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 |
if (realCond) {
/*
* Find out if the condition is a constant.
*/
Tcl_Obj *boolObj = Tcl_NewStringObj(testTokenPtr[1].start,
testTokenPtr[1].size);
Tcl_IncrRefCount(boolObj);
code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
Tcl_DecrRefCount(boolObj);
if (code == TCL_OK) {
/*
* A static condition
*/
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);
}
|
| ︙ | ︙ | |||
1439 1440 1441 1442 1443 1444 1445 |
}
} else {
/*
* No else clause: the "if" command's result is an empty string.
*/
if (compileScripts) {
| | | 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 |
}
} else {
/*
* No else clause: the "if" command's result is an empty string.
*/
if (compileScripts) {
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
}
}
/*
* Fix the unconditional jumps to the end of the "if" command.
*/
|
| ︙ | ︙ | |||
1530 1531 1532 1533 1534 1535 1536 |
"wrong # args: should be \"incr varName ?increment?\"", -1);
return TCL_ERROR;
}
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
| | > | | | > | | > > | < | | | 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 |
"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;
immValue = 0;
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;
int validLength = TclParseInteger(word, numBytes);
long n;
/*
* Note there is a danger that modifying the string could have
* undesirable side effects. In this case, TclLooksLikeInt and
* TclGetLong do not have any dependencies on shared strings so we
* should be safe.
*/
if (validLength == numBytes) {
int code;
Tcl_Obj *longObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(longObj);
code = Tcl_GetLongFromObj(NULL, longObj, &n);
Tcl_DecrRefCount(longObj);
if ((code == TCL_OK) && (-127 <= n) && (n <= 127)) {
haveImmValue = 1;
immValue = n;
}
}
if (!haveImmValue) {
TclEmitPush(
TclRegisterNewLiteral(envPtr, word, numBytes), envPtr);
}
} else {
code = TclCompileTokens(interp, incrTokenPtr+1,
incrTokenPtr->numComponents, envPtr);
if (code != TCL_OK) {
if (code == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
|
| ︙ | ︙ | |||
1716 1717 1718 1719 1720 1721 1722 |
* 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) {
| | | | | 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 |
* 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;
}
}
#if 0
} else {
/*
* We need to carefully handle the two arg case, as lappend
* always creates the variable.
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
numValues = 1;
#endif
}
/*
* Emit instructions to set/get the variable.
*/
|
| ︙ | ︙ | |||
1826 1827 1828 1829 1830 1831 1832 |
/*
* Push the operands onto the stack.
*/
for ( i = 1 ; i < numWords ; i++ ) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
| | | | < < | 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 |
/*
* Push the operands onto the stack.
*/
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;
}
}
|
| ︙ | ︙ | |||
1897 1898 1899 1900 1901 1902 1903 |
}
if (parsePtr->numWords == 1) {
/*
* Empty args case
*/
| | | | < | 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 |
}
if (parsePtr->numWords == 1) {
/*
* Empty args case
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
} else {
/*
* Push the all values onto the stack.
*/
Tcl_Token *valueTokenPtr;
int i, code, numWords;
numWords = parsePtr->numWords;
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;
}
}
|
| ︙ | ︙ | |||
1973 1974 1975 1976 1977 1978 1979 |
+ (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.
*/
| | | | 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 |
+ (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;
}
}
|
| ︙ | ︙ | |||
2068 2069 2070 2071 2072 2073 2074 |
* 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);
| | | < | | < < | 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 |
* 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;
}
}
|
| ︙ | ︙ | |||
2219 2220 2221 2222 2223 2224 2225 |
Tcl_Parse* parsePtr; /* Points to a parse structure for
* 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, exactMatch, nocase;
| > | | 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 |
Tcl_Parse* parsePtr; /* Points to a parse structure for
* 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, exactMatch, nocase;
Tcl_Obj *patternObj;
CONST char *str;
/*
* We are only interested in compiling simple regexp cases.
* Currently supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
|
| ︙ | ︙ | |||
2279 2280 2281 2282 2283 2284 2285 |
return TCL_OUT_LINE_COMPILE;
}
if (len == 0) {
/*
* The semantics of regexp are always match on re == "".
*/
| | | 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 |
return TCL_OUT_LINE_COMPILE;
}
if (len == 0) {
/*
* The semantics of regexp are always match on re == "".
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
return TCL_OK;
}
/*
* On the first (pattern) arg, check to see if any RE special characters
* are in the word. If not, this is the same as 'string equal'.
* We can use strchr here because the glob chars are all in the ascii-7
|
| ︙ | ︙ | |||
2317 2318 2319 2320 2321 2322 2323 |
* off the special chars and signal exactMatch.
*/
str++; len -= 2;
exactMatch = 1;
} else {
exactMatch = 0;
}
| | | > | < > > < | | | | | 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 |
* off the special chars and signal exactMatch.
*/
str++; len -= 2;
exactMatch = 1;
} else {
exactMatch = 0;
}
patternObj = Tcl_NewStringObj(str, len);
Tcl_IncrRefCount(patternObj);
code = (strpbrk(Tcl_GetString(patternObj), "*+?{}()[].\\|^$") != NULL);
Tcl_DecrRefCount(patternObj);
if (code) {
/* We don't do anything with REs with special chars yet. */
return TCL_OUT_LINE_COMPILE;
}
if (exactMatch) {
TclEmitPush(TclRegisterNewLiteral(envPtr, str, len), envPtr);
} else {
/*
* This needs to find the substring anywhere in the string, so
* use string match and *foo*.
*/
char *newStr = ckalloc((unsigned) len + 3);
newStr[0] = '*';
strncpy(newStr + 1, str, (size_t) len);
newStr[len+1] = '*';
newStr[len+2] = '\0';
TclEmitPush(TclRegisterNewLiteral(envPtr, newStr, len+2), envPtr);
ckfree((char *) newStr);
}
/*
* 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;
}
}
|
| ︙ | ︙ | |||
2412 2413 2414 2415 2416 2417 2418 |
switch (parsePtr->numWords) {
case 1: {
/*
* Simple case: [return]
* Just push the literal string "".
*/
| | | | | 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 |
switch (parsePtr->numWords) {
case 1: {
/*
* Simple case: [return]
* Just push the literal string "".
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
break;
}
case 2: {
/*
* More complex cases:
* [return "foo"]
* [return $value]
* [return [otherCmd]]
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
/*
* [return "foo"] case: the parse token is a simple word,
* so just push it.
*/
TclEmitPush(TclRegisterNewLiteral(envPtr, varTokenPtr[1].start,
varTokenPtr[1].size), envPtr);
} else {
/*
* 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.
|
| ︙ | ︙ | |||
2519 2520 2521 2522 2523 2524 2525 |
* procedure body and if the name is simple text that does not include
* namespace qualifiers.
*/
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
| | < | | | 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 |
* procedure body and if the name is simple text that does not include
* 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;
}
}
|
| ︙ | ︙ | |||
2696 2697 2698 2699 2700 2701 2702 |
/*
* Push the two operands onto the stack.
*/
for (i = 0; i < 2; i++) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
| | | < | 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 |
/*
* Push the two operands onto the stack.
*/
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;
}
}
|
| ︙ | ︙ | |||
2727 2728 2729 2730 2731 2732 2733 |
/*
* Push the two operands onto the stack.
*/
for (i = 0; i < 2; i++) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
| | | < | 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 |
/*
* Push the two operands onto the stack.
*/
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;
}
}
|
| ︙ | ︙ | |||
2758 2759 2760 2761 2762 2763 2764 | * Here someone is asking for the length of a static string. * Just push the actual character (not byte) length. */ char buf[TCL_INTEGER_SPACE]; int len = Tcl_NumUtfChars(varTokenPtr[1].start, varTokenPtr[1].size); len = sprintf(buf, "%d", len); | | | | 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 |
* Here someone is asking for the length of a static string.
* Just push the actual character (not byte) length.
*/
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);
return TCL_OK;
}
case STR_MATCH: {
int i, length, exactMatch = 0, nocase = 0;
CONST char *str;
if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
/* Fail at run time, not in compilation */
return TCL_OUT_LINE_COMPILE;
}
if (parsePtr->numWords == 5) {
|
| ︙ | ︙ | |||
2804 2805 2806 2807 2808 2809 2810 |
str = varTokenPtr[1].start;
length = varTokenPtr[1].size;
if (!nocase && (i == 0)) {
/*
* On the first (pattern) arg, check to see if any
* glob special characters are in the word '*[]?\\'.
* If not, this is the same as 'string equal'. We
| | | | | | > | | | 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 |
str = varTokenPtr[1].start;
length = varTokenPtr[1].size;
if (!nocase && (i == 0)) {
/*
* On the first (pattern) arg, check to see if any
* glob special characters are in the word '*[]?\\'.
* If not, this is the same as 'string equal'. We
* can use strpbrk here because the glob chars are all
* in the ascii-7 range. If -nocase was specified,
* we can't do this because INST_STR_EQ has no support
* for nocase.
*/
Tcl_Obj *copy = Tcl_NewStringObj(str, length);
Tcl_IncrRefCount(copy);
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;
}
}
|
| ︙ | ︙ | |||
2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 |
}
return TCL_OK;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileWhileCmd --
*
* Procedure called to compile the "while" command.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
return TCL_OK;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclCompileVariableCmd --
*
* Procedure called to reserve the local variables for the
* "variable" command. The command itself is *not* compiled.
*
* Results:
* Always returns TCL_OUT_LINE_COMPILE.
*
* Side effects:
* Indexed local variables are added to the environment.
*
*----------------------------------------------------------------------
*/
int
TclCompileVariableCmd(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. */
{
Tcl_Token *varTokenPtr;
int i, numWords;
CONST char *varName, *tail;
if (envPtr->procPtr == NULL) {
return TCL_OUT_LINE_COMPILE;
}
numWords = parsePtr->numWords;
varTokenPtr = parsePtr->tokenPtr
+ (parsePtr->tokenPtr->numComponents + 1);
for (i = 1; i < numWords; i += 2) {
if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
varName = varTokenPtr[1].start;
tail = varName + varTokenPtr[1].size - 1;
if ((*tail == ')') || (tail < varName)) continue;
while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) {
tail--;
}
if ((*tail == ':') && (tail > varName)) {
tail++;
}
(void) TclFindCompiledLocal(tail, (tail-varName+1),
/*create*/ 1, /*flags*/ 0, envPtr->procPtr);
varTokenPtr = varTokenPtr + (varTokenPtr->numComponents + 1);
}
}
return TCL_OUT_LINE_COMPILE;
}
/*
*----------------------------------------------------------------------
*
* TclCompileWhileCmd --
*
* Procedure called to compile the "while" command.
|
| ︙ | ︙ | |||
2876 2877 2878 2879 2880 2881 2882 2883 |
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist;
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. */
int boolVal;
| > < < | 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 |
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist;
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;
}
|
| ︙ | ︙ | |||
2908 2909 2910 2911 2912 2913 2914 |
return TCL_OUT_LINE_COMPILE;
}
/*
* Find out if the condition is a constant.
*/
| | < | < < < < < < < | < < | | < < < < | | 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 |
return TCL_OUT_LINE_COMPILE;
}
/*
* Find out if the condition is a constant.
*/
boolObj = Tcl_NewStringObj(testTokenPtr[1].start, testTokenPtr[1].size);
Tcl_IncrRefCount(boolObj);
code = Tcl_GetBooleanFromObj(NULL, boolObj, &boolVal);
Tcl_DecrRefCount(boolObj);
if (code == TCL_OK) {
if (boolVal) {
/*
* it is an infinite loop
*/
loopMayEnd = 0;
} else {
/*
* This is an empty loop: "while 0 {...}" or such.
* Compile no bytecodes.
*/
goto pushResult;
}
}
/*
* Create a ExceptionRange record for the loop body. This is used to
* implement break and continue.
*/
envPtr->exceptDepth++;
envPtr->maxExceptDepth =
|
| ︙ | ︙ | |||
3049 3050 3051 3052 3053 3054 3055 |
/*
* The while command's result is an empty string.
*/
pushResult:
envPtr->currStackDepth = savedStackDepth;
| | | 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 |
/*
* The while command's result is an empty string.
*/
pushResult:
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
envPtr->exceptDepth--;
return TCL_OK;
error:
envPtr->exceptDepth--;
return code;
}
|
| ︙ | ︙ | |||
3085 3086 3087 3088 3089 3090 3091 |
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
| | | | > > > | 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 |
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 */
{
Tcl_Parse elemParse;
int gotElemParse = 0;
register CONST char *p;
CONST char *name, *elName;
register int i, n;
int nameChars, elNameChars, simpleVarName, localIndex;
int code = TCL_OK;
Tcl_DString copy;
Tcl_DStringInit(©);
/*
* 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.
|
| ︙ | ︙ | |||
3220 3221 3222 3223 3224 3225 3226 |
envPtr->procPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/* we'll push the name */
localIndex = -1;
}
}
if (localIndex < 0) {
| | < | | | | | < < | < > | 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 |
envPtr->procPtr);
if ((flags & TCL_NO_LARGE_INDEX) && (localIndex > 255)) {
/* we'll push the name */
localIndex = -1;
}
}
if (localIndex < 0) {
TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameChars), envPtr);
}
/*
* Compile the element script, if any.
*/
if (elName != NULL) {
/*
* Temporarily replace the '(' and ')' by '"'s.
*/
Tcl_DStringAppend(©, "\"", 1);
Tcl_DStringAppend(©, elName, elNameChars);
Tcl_DStringAppend(©, "\"", 1);
code = Tcl_ParseCommand(interp, Tcl_DStringValue(©),
elNameChars+2, /*nested*/ 0, &elemParse);
gotElemParse = 1;
if ((code != TCL_OK) || (elemParse.numWords > 1)) {
char buffer[160];
sprintf(buffer, "\n (parsing index for array \"%.*s\")",
TclMin(nameChars, 100), name);
Tcl_AddObjErrorInfo(interp, buffer, -1);
code = TCL_ERROR;
goto done;
} else if (elemParse.numWords == 1) {
code = TclCompileTokens(interp, elemParse.tokenPtr+1,
elemParse.tokenPtr->numComponents, 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 (gotElemParse) {
Tcl_FreeParse(&elemParse);
}
Tcl_DStringFree(©);
*localIndexPtr = localIndex;
*simpleVarNamePtr = simpleVarName;
*isScalarPtr = (elName == NULL);
return code;
}
|
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.6.14.3 2002/08/20 20:25:25 das Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * The stuff below is a bit of a hack so that this file can be used in |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
* this module.
*/
typedef struct ExprInfo {
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Structure filled with information about
* the parsed expression. */
| | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
* this module.
*/
typedef struct ExprInfo {
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Parse *parsePtr; /* Structure filled with information about
* the parsed expression. */
CONST char *expr; /* The expression that was originally passed
* to TclCompileExpr. */
CONST char *lastChar; /* Points just after last byte of expr. */
int hasOperators; /* Set 1 if the expr has operators; 0 if
* expr is only a primary. If 1 after
* compiling an expr, a tryCvtToNumeric
* instruction is emitted to convert the
* primary to a number if possible. */
} ExprInfo;
|
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
char *name; /* Name of the operator. */
int numOperands; /* Number of operands. 0 if the operator
* requires special handling. */
int instruction; /* Instruction opcode for the operator.
* Ignored if numOperands is 0. */
} OperatorDesc;
| | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
char *name; /* Name of the operator. */
int numOperands; /* Number of operands. 0 if the operator
* requires special handling. */
int instruction; /* Instruction opcode for the operator.
* Ignored if numOperands is 0. */
} OperatorDesc;
static OperatorDesc operatorTable[] = {
{"*", 2, INST_MULT},
{"/", 2, INST_DIV},
{"%", 2, INST_MOD},
{"+", 0},
{"-", 0},
{"<<", 2, INST_LSHIFT},
{">>", 2, INST_RSHIFT},
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 | Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, CompileEnv *envPtr, Tcl_Token **endPtrPtr)); static int CompileLandOrLorExpr _ANSI_ARGS_(( Tcl_Token *exprTokenPtr, int opIndex, ExprInfo *infoPtr, CompileEnv *envPtr, Tcl_Token **endPtrPtr)); static int CompileMathFuncCall _ANSI_ARGS_(( | | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 | Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, CompileEnv *envPtr, Tcl_Token **endPtrPtr)); static int CompileLandOrLorExpr _ANSI_ARGS_(( Tcl_Token *exprTokenPtr, int opIndex, ExprInfo *infoPtr, CompileEnv *envPtr, Tcl_Token **endPtrPtr)); static int CompileMathFuncCall _ANSI_ARGS_(( Tcl_Token *exprTokenPtr, CONST char *funcName, ExprInfo *infoPtr, CompileEnv *envPtr, Tcl_Token **endPtrPtr)); static int CompileSubExpr _ANSI_ARGS_(( Tcl_Token *exprTokenPtr, ExprInfo *infoPtr, CompileEnv *envPtr)); static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr)); |
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
*
*----------------------------------------------------------------------
*/
int
TclCompileExpr(interp, script, numBytes, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
| | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
*
*----------------------------------------------------------------------
*/
int
TclCompileExpr(interp, script, numBytes, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *script; /* The source script to compile. */
int numBytes; /* Number of bytes in script. If < 0, the
* string consists of all bytes up to the
* first null character. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
ExprInfo info;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Interp *interp = infoPtr->interp;
Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
OperatorDesc *opDescPtr;
Tcl_HashEntry *hPtr;
| | | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Tcl_Interp *interp = infoPtr->interp;
Tcl_Token *tokenPtr, *endPtr, *afterSubexprPtr;
OperatorDesc *opDescPtr;
Tcl_HashEntry *hPtr;
CONST char *operator;
Tcl_DString opBuf;
int objIndex, opIndex, length, code;
char buffer[TCL_UTF_MAX];
if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) {
panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n",
exprTokenPtr->type);
}
|
| ︙ | ︙ | |||
371 372 373 374 375 376 377 |
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_TEXT:
if (tokenPtr->size > 0) {
| | | | | < | | 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 |
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_TEXT:
if (tokenPtr->size > 0) {
objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start,
tokenPtr->size);
} else {
objIndex = TclRegisterNewLiteral(envPtr, "", 0);
}
TclEmitPush(objIndex, envPtr);
tokenPtr += 1;
break;
case TCL_TOKEN_BS:
length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
buffer);
if (length > 0) {
objIndex = TclRegisterNewLiteral(envPtr, buffer, length);
} else {
objIndex = TclRegisterNewLiteral(envPtr, "", 0);
}
TclEmitPush(objIndex, envPtr);
tokenPtr += 1;
break;
case TCL_TOKEN_COMMAND:
code = TclCompileScript(interp, tokenPtr->start+1,
|
| ︙ | ︙ | |||
420 421 422 423 424 425 426 |
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_OPERATOR:
/*
| | < | | < < < < < < | | < < | | | 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 |
goto done;
}
tokenPtr += (tokenPtr->numComponents + 1);
break;
case TCL_TOKEN_OPERATOR:
/*
* Look up the operator. If the operator isn't found, treat it
* as a math function.
*/
Tcl_DStringInit(&opBuf);
operator = Tcl_DStringAppend(&opBuf,
tokenPtr->start, tokenPtr->size);
hPtr = Tcl_FindHashEntry(&opHashTable, operator);
if (hPtr == NULL) {
code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr,
envPtr, &endPtr);
Tcl_DStringFree(&opBuf);
if (code != TCL_OK) {
goto done;
}
tokenPtr = endPtr;
break;
}
Tcl_DStringFree(&opBuf);
opIndex = (int) Tcl_GetHashValue(hPtr);
opDescPtr = &(operatorTable[opIndex]);
/*
* If the operator is "normal", compile it using information
* from the operator table.
*/
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
/*
* Convert the first operand to the result that Tcl requires:
* "0" or "1". Eventually we'll use a new instruction for this.
*/
TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup);
| | | | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
/*
* Convert the first operand to the result that Tcl requires:
* "0" or "1". Eventually we'll use a new instruction for this.
*/
TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &lhsTrueFixup);
TclEmitPush(TclRegisterNewLiteral(envPtr, "0", 1), envPtr);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &lhsEndFixup);
dist = (envPtr->codeNext - envPtr->codeStart) - lhsTrueFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &lhsTrueFixup, dist, 127)) {
badDist:
panic("CompileLandOrLorExpr: bad jump distance %d\n", dist);
}
envPtr->currStackDepth = savedStackDepth;
TclEmitPush(TclRegisterNewLiteral(envPtr, "1", 1), envPtr);
dist = (envPtr->codeNext - envPtr->codeStart) - lhsEndFixup.codeOffset;
if (TclFixupForwardJump(envPtr, &lhsEndFixup, dist, 127)) {
goto badDist;
}
/*
* Emit the "short circuit" jump around the rest of the expression.
|
| ︙ | ︙ | |||
832 833 834 835 836 837 838 |
*----------------------------------------------------------------------
*/
static int
CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* containing the math function call. */
| | | 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
*----------------------------------------------------------------------
*/
static int
CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr)
Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token
* containing the math function call. */
CONST char *funcName; /* Name of the math function. */
ExprInfo *infoPtr; /* Describes the compilation state for the
* expression being compiled. */
CompileEnv *envPtr; /* Holds resulting instructions. */
Tcl_Token **endPtrPtr; /* If successful, a pointer to the token
* just after the last token in the
* subexpression is stored here. */
{
|
| ︙ | ︙ | |||
866 867 868 869 870 871 872 |
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
/*
* If not a builtin function, push an object with the function's name.
*/
if (mathFuncPtr->builtinFuncIndex < 0) {
| | < | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 |
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
/*
* If not a builtin function, push an object with the function's name.
*/
if (mathFuncPtr->builtinFuncIndex < 0) {
TclEmitPush(TclRegisterNewLiteral(envPtr, funcName, -1), envPtr);
}
/*
* Compile any arguments for the function.
*/
tokenPtr = exprTokenPtr+2;
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 971 972 973 |
* expression being compiled. */
{
int numBytes = (infoPtr->lastChar - infoPtr->expr);
char buffer[100];
sprintf(buffer, "syntax error in expression \"%.*s\"",
((numBytes > 60)? 60 : numBytes), infoPtr->expr);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
buffer, (char *) NULL);
}
| > | 953 954 955 956 957 958 959 960 961 962 963 |
* expression being compiled. */
{
int numBytes = (infoPtr->lastChar - infoPtr->expr);
char buffer[100];
sprintf(buffer, "syntax error in expression \"%.*s\"",
((numBytes > 60)? 60 : numBytes), infoPtr->expr);
Tcl_ResetResult(infoPtr->interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
buffer, (char *) NULL);
}
|
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.25.4.3 2002/08/20 20:25:25 das Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
/*
* Table of all AuxData types.
|
| ︙ | ︙ | |||
48 49 50 51 52 53 54 | * and next to topmost stack elements. * * Note that the load, store, and incr instructions do not distinguish local * from global variables; the bytecode interpreter at runtime uses the * existence of a procedure call frame to distinguish these. */ | | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
* and next to topmost stack elements.
*
* Note that the load, store, and incr instructions do not distinguish local
* from global variables; the bytecode interpreter at runtime uses the
* existence of a procedure call frame to distinguish these.
*/
InstructionDesc tclInstructionTable[] = {
/* Name Bytes stackEffect #Opnds Operand types Stack top, next */
{"done", 1, -1, 0, {OPERAND_NONE}},
/* Finish ByteCode execution and return stktop (top stack item) */
{"push1", 2, +1, 1, {OPERAND_UINT1}},
/* Push object at ByteCode objArray[op1] */
{"push4", 5, +1, 1, {OPERAND_UINT4}},
/* Push object at ByteCode objArray[op4] */
|
| ︙ | ︙ | |||
288 289 290 291 292 293 294 |
CompileEnv *envPtr, int cmdNumber,
int srcOffset, int codeOffset));
static void FreeByteCodeInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
static int GetCmdLocEncodingSize _ANSI_ARGS_((
CompileEnv *envPtr));
static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
| > | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
CompileEnv *envPtr, int cmdNumber,
int srcOffset, int codeOffset));
static void FreeByteCodeInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
static int GetCmdLocEncodingSize _ANSI_ARGS_((
CompileEnv *envPtr));
static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *script, CONST char *command,
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));
|
| ︙ | ︙ | |||
794 795 796 797 798 799 800 |
*
*----------------------------------------------------------------------
*/
int
TclCompileScript(interp, script, numBytes, nested, envPtr)
Tcl_Interp *interp; /* Used for error and status reporting. */
| | | | 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 |
*
*----------------------------------------------------------------------
*/
int
TclCompileScript(interp, script, numBytes, nested, envPtr)
Tcl_Interp *interp; /* Used for error and status reporting. */
CONST char *script; /* The source script to compile. */
int numBytes; /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
int nested; /* Non-zero means this is a nested command:
* close bracket ']' should be considered a
* command terminator. If zero, close
* bracket has no special meaning. */
CompileEnv *envPtr; /* Holds resulting instructions. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Parse parse;
int lastTopLevelCmdIndex = -1;
/* Index of most recent toplevel command in
* the command location table. Initialized
* to avoid compiler warning. */
int startCodeOffset = -1; /* Offset of first byte of current command's
* code. Init. to avoid compiler warning. */
unsigned char *entryCodeNext = envPtr->codeNext;
CONST char *p, *next;
Namespace *cmdNsPtr;
Command *cmdPtr;
Tcl_Token *tokenPtr;
int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
int commandLength, objIndex, code;
char prev;
Tcl_DString ds;
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 949 950 951 952 953 954 955 |
cmdPtr = (Command *) Tcl_FindCommand(interp,
Tcl_DStringValue(&ds),
(Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
if ((cmdPtr != NULL)
&& (cmdPtr->compileProc != NULL)
&& !(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) {
/* do nothing */
| > | 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 |
cmdPtr = (Command *) Tcl_FindCommand(interp,
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) {
/* do nothing */
|
| ︙ | ︙ | |||
967 968 969 970 971 972 973 | /* * No compile procedure so push the word. If the * command was found, push a CmdName object to * reduce runtime lookups. */ | | | < | | < | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 |
/*
* No compile procedure so push the word. If the
* command was found, push a CmdName object to
* reduce runtime lookups.
*/
objIndex = TclRegisterNewLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
if (cmdPtr != NULL) {
TclSetCmdNameObj(interp,
envPtr->literalArrayPtr[objIndex].objPtr,
cmdPtr);
}
} else {
objIndex = TclRegisterNewLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
}
TclEmitPush(objIndex, envPtr);
} else {
/*
* The word is not a simple string of characters.
*/
|
| ︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 |
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[TCL_UTF_MAX];
| | | | 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 |
int count; /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[TCL_UTF_MAX];
CONST char *name, *p;
int numObjsToConcat, nameBytes, localVarName, localVar;
int length, i, code;
unsigned char *entryCodeNext = envPtr->codeNext;
Tcl_DStringInit(&textBuffer);
numObjsToConcat = 0;
for ( ; count > 0; count--, tokenPtr++) {
switch (tokenPtr->type) {
|
| ︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 | Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); } /* | > | > > > > > | | | | > > > > > | | > | < | < < | | > | | | < | 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 |
Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
TclEmitPush(literal, envPtr);
numObjsToConcat++;
Tcl_DStringFree(&textBuffer);
}
/*
* Determine how the variable name should be handled: if it contains
* any namespace qualifiers it is not a local variable (localVarName=-1);
* if it looks like an array element and the token has a single component,
* it should not be created here [Bug 569438] (localVarName=0); otherwise,
* the local variable can safely be created (localVarName=1).
*/
name = tokenPtr[1].start;
nameBytes = tokenPtr[1].size;
localVarName = -1;
if (envPtr->procPtr != NULL) {
localVarName = 1;
for (i = 0, p = name; i < nameBytes; i++, p++) {
if ((*p == ':') && (i < (nameBytes-1))
&& (*(p+1) == ':')) {
localVarName = -1;
break;
} else if ((*p == '(')
&& (tokenPtr->numComponents == 1)
&& (*(name + nameBytes - 1) == ')')) {
localVarName = 0;
break;
}
}
}
/*
* Either push the variable's name, or find its index in
* the array of local variables in a procedure frame.
*/
localVar = -1;
if (localVarName != -1) {
localVar = TclFindCompiledLocal(name, nameBytes,
localVarName, /*flags*/ 0, envPtr->procPtr);
}
if (localVar < 0) {
TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
envPtr);
}
/*
* Emit instructions to load the variable.
*/
if (tokenPtr->numComponents == 1) {
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 |
int numWords; /* Number of word tokens starting at
* tokenPtr. Must be at least 1. Each word
* token contains one or more subtokens. */
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
Tcl_Token *wordPtr;
int range, numBytes, i, code;
| | | 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 |
int numWords; /* Number of word tokens starting at
* tokenPtr. Must be at least 1. Each word
* token contains one or more subtokens. */
CompileEnv *envPtr; /* Holds the resulting instructions. */
{
Tcl_Token *wordPtr;
int range, numBytes, i, code;
CONST char *script;
range = -1;
code = TCL_OK;
/*
* If the expression is a single word that doesn't require
* substitutions, just compile it's string into inline instructions.
|
| ︙ | ︙ | |||
1625 1626 1627 1628 1629 1630 1631 |
*----------------------------------------------------------------------
*/
static void
LogCompilationInfo(interp, script, command, length)
Tcl_Interp *interp; /* Interpreter in which to log the
* information. */
| | | | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 |
*----------------------------------------------------------------------
*/
static void
LogCompilationInfo(interp, script, command, length)
Tcl_Interp *interp; /* Interpreter in which to log the
* information. */
CONST char *script; /* First character in script containing
* command (must be <= command). */
CONST char *command; /* First character in command that
* generated the error. */
int length; /* Number of bytes in command (-1 means
* use all bytes up to first null byte). */
{
char buffer[200];
register CONST char *p;
char *ellipsis = "";
Interp *iPtr = (Interp *) interp;
if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
* Someone else has already logged error information for this
* command; we shouldn't add anything more.
|
| ︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 |
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
localPtr->nameLength = nameBytes;
localPtr->frameIndex = localVar;
| | | 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 |
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
localPtr->nameLength = nameBytes;
localPtr->frameIndex = localVar;
localPtr->flags = flags | VAR_UNDEFINED;
if (name == NULL) {
localPtr->flags |= VAR_TEMPORARY;
}
localPtr->defValuePtr = NULL;
localPtr->resolveInfo = NULL;
if (name != NULL) {
|
| ︙ | ︙ | |||
1880 1881 1882 1883 1884 1885 1886 | varPtr->value.objPtr = NULL; varPtr->name = localPtr->name; /* will be just '\0' if temp var */ varPtr->nsPtr = NULL; varPtr->hPtr = NULL; varPtr->refCount = 0; varPtr->tracePtr = NULL; varPtr->searchPtr = NULL; | | | 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 |
varPtr->value.objPtr = NULL;
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
varPtr->nsPtr = NULL;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
varPtr->flags = localPtr->flags;
}
varPtr++;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2504 2505 2506 2507 2508 2509 2510 | * * Returns a pointer to the table describing Tcl bytecode instructions. * This procedure is defined so that clients can access the pointer from * outside the TCL DLLs. * * Results: * Returns a pointer to the global instruction table, same as the | | | | 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 |
*
* Returns a pointer to the table describing Tcl bytecode instructions.
* This procedure is defined so that clients can access the pointer from
* outside the TCL DLLs.
*
* Results:
* Returns a pointer to the global instruction table, same as the
* expression (&tclInstructionTable[0]).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void * /* == InstructionDesc* == */
TclGetInstructionTable()
{
return &tclInstructionTable[0];
}
/*
*--------------------------------------------------------------
*
* TclRegisterAuxDataType --
*
|
| ︙ | ︙ | |||
3172 3173 3174 3175 3176 3177 3178 |
int
TclPrintInstruction(codePtr, pc)
ByteCode* codePtr; /* Bytecode containing the instruction. */
unsigned char *pc; /* Points to first byte of instruction. */
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
| | | 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 |
int
TclPrintInstruction(codePtr, pc)
ByteCode* codePtr; /* Bytecode containing the instruction. */
unsigned char *pc; /* Points to first byte of instruction. */
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
register InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned int pcOffset = (pc - codeStart);
int opnd, i, j;
fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
|
| ︙ | ︙ |
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.16.4.3 2002/08/20 20:25:25 das Exp $ */ #ifndef _TCLCOMPILATION #define _TCLCOMPILATION 1 #ifndef _TCLINT #include "tclInt.h" |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | /* *------------------------------------------------------------------------ * Variables related to compilation. These are used in tclCompile.c, * tclExecute.c, tclBasic.c, and their clients. *------------------------------------------------------------------------ */ | < < < < < < < < | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | /* *------------------------------------------------------------------------ * Variables related to compilation. These are used in tclCompile.c, * tclExecute.c, tclBasic.c, and their clients. *------------------------------------------------------------------------ */ #ifdef TCL_COMPILE_DEBUG /* * Variable that controls whether compilation tracing is enabled and, if so, * what level of tracing is desired: * 0: no compilation tracing * 1: summarize compilation of top level cmds and proc bodies * 2: display all instructions of each ByteCode compiled |
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
#ifdef TCL_COMPILE_STATS
Tcl_Time createTime; /* Absolute time when the ByteCode was
* created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;
/*
| | | | | | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
#ifdef TCL_COMPILE_STATS
Tcl_Time createTime; /* Absolute time when the ByteCode was
* created. */
#endif /* TCL_COMPILE_STATS */
} ByteCode;
/*
* Opcodes for the Tcl bytecode instructions. These must correspond to
* the entries in the table of instruction descriptions,
* tclInstructionTable, in tclCompile.c. Also, the order and number of
* the expression opcodes (e.g., INST_LOR) must match the entries in
* the array operatorStrings in tclExecute.c.
*/
/* Opcodes 0 to 9 */
#define INST_DONE 0
#define INST_PUSH1 1
#define INST_PUSH4 2
#define INST_POP 3
|
| ︙ | ︙ | |||
562 563 564 565 566 567 568 |
* is (1-opnd1).
*/
int numOperands; /* Number of operands. */
InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
/* The type of each operand. */
} InstructionDesc;
| | | | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
* is (1-opnd1).
*/
int numOperands; /* Number of operands. */
InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
/* The type of each operand. */
} InstructionDesc;
extern InstructionDesc tclInstructionTable[];
/*
* Definitions of the values of the INST_CALL_BUILTIN_FUNC instruction's
* operand byte. Each value denotes a builtin Tcl math function. These
* values must correspond to the entries in the tclBuiltinFuncTable array
* below and to the values stored in the tclInt.h MathFunc structure's
* builtinFuncIndex field.
*/
#define BUILTIN_FUNC_ACOS 0
#define BUILTIN_FUNC_ASIN 1
#define BUILTIN_FUNC_ATAN 2
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 |
Tcl_ValueType argTypes[MAX_MATH_ARGS];
/* Acceptable types for each argument. */
CallBuiltinFuncProc *proc; /* Procedure implementing this function. */
ClientData clientData; /* Additional argument to pass to the
* function when invoking it. */
} BuiltinFunc;
| | | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
Tcl_ValueType argTypes[MAX_MATH_ARGS];
/* Acceptable types for each argument. */
CallBuiltinFuncProc *proc; /* Procedure implementing this function. */
ClientData clientData; /* Additional argument to pass to the
* function when invoking it. */
} BuiltinFunc;
extern BuiltinFunc tclBuiltinFuncTable[];
/*
* Compilation of some Tcl constructs such as if commands and the logical or
* (||) and logical and (&&) operators in expressions requires the
* generation of forward jumps. Since the PC target of these jumps isn't
* known when the jumps are emitted, we record the offset of each jump in an
* array of JumpFixup structures. There is one array for each sequence of
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 | /* *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ EXTERN int TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc, | | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 | /* *---------------------------------------------------------------- * Procedures exported by tclBasic.c to be used within the engine. *---------------------------------------------------------------- */ EXTERN int TclEvalObjvInternal _ANSI_ARGS_((Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[], CONST char *command, int length, int flags)); EXTERN int TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp)); /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c |
| ︙ | ︙ | |||
746 747 748 749 750 751 752 | */ EXTERN void TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr)); EXTERN int TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr)); EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp, | | | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 | */ EXTERN void TclCleanupByteCode _ANSI_ARGS_((ByteCode *codePtr)); EXTERN int TclCompileCmdWord _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr)); EXTERN int TclCompileExpr _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, int numBytes, CompileEnv *envPtr)); EXTERN int TclCompileExprWords _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr)); EXTERN int TclCompileScript _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script, int numBytes, int nested, CompileEnv *envPtr)); EXTERN int TclCompileTokens _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr)); EXTERN int TclCreateAuxData _ANSI_ARGS_((ClientData clientData, AuxDataType *typePtr, CompileEnv *envPtr)); EXTERN int TclCreateExceptRange _ANSI_ARGS_(( |
| ︙ | ︙ | |||
831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 |
/*
*----------------------------------------------------------------
* Macros used by Tcl bytecode compilation and execution modules
* inside the Tcl core but not used outside.
*----------------------------------------------------------------
*/
/*
* Macro used to update the stack requirements.
* It is called by the macros TclEmitOpCode, TclEmitInst1 and
* TclEmitInst4.
* Remark that the very last instruction of a bytecode always
* reduces the stack level: INST_DONE or INST_POP, so that the
* maxStackdepth is always updated.
*/
#define TclUpdateStackReqs(op, i, envPtr) \
{\
| > > > > > > > > > | | 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 |
/*
*----------------------------------------------------------------
* Macros used by Tcl bytecode compilation and execution modules
* inside the Tcl core but not used outside.
*----------------------------------------------------------------
*/
/*
* Form of TclRegisterLiteral with onHeap == 0.
* In that case, it is safe to cast away CONSTness, and it
* is cleanest to do that here, all in one place.
*/
#define TclRegisterNewLiteral(envPtr, bytes, length) \
TclRegisterLiteral(envPtr, (char *)(bytes), length, /*onHeap*/ 0)
/*
* Macro used to update the stack requirements.
* It is called by the macros TclEmitOpCode, TclEmitInst1 and
* TclEmitInst4.
* Remark that the very last instruction of a bytecode always
* reduces the stack level: INST_DONE or INST_POP, so that the
* maxStackdepth is always updated.
*/
#define TclUpdateStackReqs(op, i, envPtr) \
{\
int delta = tclInstructionTable[(op)].stackEffect;\
if (delta) {\
if (delta < 0) {\
if((envPtr)->maxStackDepth < (envPtr)->currStackDepth) {\
(envPtr)->maxStackDepth = (envPtr)->currStackDepth;\
}\
if (delta == INT_MIN) {\
delta = 1 - (i);\
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 | * array. These support, respectively, a maximum of 256 (2**8) and 2**32 * objects in a CompileEnv. The ANSI C "prototype" for this macro is: * * EXTERN void TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr)); */ #define TclEmitPush(objIndex, envPtr) \ | > > | | | | > | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 |
* array. These support, respectively, a maximum of 256 (2**8) and 2**32
* objects in a CompileEnv. The ANSI C "prototype" for this macro is:
*
* EXTERN void TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr));
*/
#define TclEmitPush(objIndex, envPtr) \
{\
register int objIndexCopy = (objIndex);\
if (objIndexCopy <= 255) { \
TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \
} else { \
TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \
}\
}
/*
* Macros to update a (signed or unsigned) integer starting at a pointer.
* The two variants depend on the number of bytes. The ANSI C "prototypes"
* for these macros are:
*
|
| ︙ | ︙ |
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.63.2.5 2002/08/20 20:25:25 das Exp $ */ #ifndef _TCLDECLS #define _TCLDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl |
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | */ /* 0 */ EXTERN int Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 1 */ | | > | | | | | 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 | */ /* 0 */ EXTERN int Tcl_PkgProvideEx _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 1 */ EXTERN CONST84_RETURN char * Tcl_PkgRequireEx _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 2 */ EXTERN void Tcl_Panic _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 3 */ EXTERN char * Tcl_Alloc _ANSI_ARGS_((unsigned int size)); /* 4 */ EXTERN void Tcl_Free _ANSI_ARGS_((char * ptr)); /* 5 */ EXTERN char * Tcl_Realloc _ANSI_ARGS_((char * ptr, unsigned int size)); /* 6 */ EXTERN char * Tcl_DbCkalloc _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 7 */ EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 8 */ EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler _ANSI_ARGS_((int fd, int mask, Tcl_FileProc * proc, ClientData clientData)); #endif /* UNIX */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 10 */ EXTERN void Tcl_DeleteFileHandler _ANSI_ARGS_((int fd)); #endif /* UNIX */ /* 11 */ EXTERN void Tcl_SetTimer _ANSI_ARGS_((Tcl_Time * timePtr)); /* 12 */ EXTERN void Tcl_Sleep _ANSI_ARGS_((int ms)); |
| ︙ | ︙ | |||
267 268 269 270 271 272 273 | EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_(( Tcl_IdleProc * idleProc, ClientData clientData)); /* 81 */ EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 82 */ | | | | 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 | EXTERN void Tcl_CancelIdleCall _ANSI_ARGS_(( Tcl_IdleProc * idleProc, ClientData clientData)); /* 81 */ EXTERN int Tcl_Close _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 82 */ EXTERN int Tcl_CommandComplete _ANSI_ARGS_((CONST char * cmd)); /* 83 */ EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 84 */ EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char * src, char * dst, int flags)); /* 85 */ EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_(( CONST char * src, int length, char * dst, int flags)); /* 86 */ EXTERN int Tcl_CreateAlias _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int argc, CONST84 char * CONST * argv)); /* 87 */ EXTERN int Tcl_CreateAliasObj _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel _ANSI_ARGS_(( |
| ︙ | ︙ | |||
372 373 374 375 376 377 378 | EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( Tcl_HashEntry * entryPtr)); /* 109 */ EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( Tcl_HashTable * tablePtr)); /* 110 */ EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp * interp)); | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 | EXTERN void Tcl_DeleteHashEntry _ANSI_ARGS_(( Tcl_HashEntry * entryPtr)); /* 109 */ EXTERN void Tcl_DeleteHashTable _ANSI_ARGS_(( Tcl_HashTable * tablePtr)); /* 110 */ EXTERN void Tcl_DeleteInterp _ANSI_ARGS_((Tcl_Interp * interp)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 111 */ EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); #endif /* UNIX */ #ifdef __WIN32__ /* 111 */ EXTERN void Tcl_DetachPids _ANSI_ARGS_((int numPids, |
| ︙ | ︙ | |||
426 427 428 429 430 431 432 | Tcl_DString * dsPtr, int length)); /* 125 */ EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_(( Tcl_DString * dsPtr)); /* 126 */ EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan)); /* 127 */ | | | | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 | Tcl_DString * dsPtr, int length)); /* 125 */ EXTERN void Tcl_DStringStartSublist _ANSI_ARGS_(( Tcl_DString * dsPtr)); /* 126 */ EXTERN int Tcl_Eof _ANSI_ARGS_((Tcl_Channel chan)); /* 127 */ EXTERN CONST84_RETURN char * Tcl_ErrnoId _ANSI_ARGS_((void)); /* 128 */ EXTERN CONST84_RETURN char * Tcl_ErrnoMsg _ANSI_ARGS_((int err)); /* 129 */ EXTERN int Tcl_Eval _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 130 */ EXTERN int Tcl_EvalFile _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 131 */ EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 132 */ |
| ︙ | ︙ | |||
489 490 491 492 493 494 495 | /* 147 */ EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp * interp)); /* 148 */ EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, | | | 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 | /* 147 */ EXTERN void Tcl_FreeResult _ANSI_ARGS_((Tcl_Interp * interp)); /* 148 */ EXTERN int Tcl_GetAlias _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, CONST84 char *** argvPtr)); /* 149 */ EXTERN int Tcl_GetAliasObj _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 150 */ |
| ︙ | ︙ | |||
515 516 517 518 519 520 521 | int direction, ClientData * handlePtr)); /* 154 */ EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_(( Tcl_Channel chan)); /* 155 */ EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */ | | > | | | | | 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 | int direction, ClientData * handlePtr)); /* 154 */ EXTERN ClientData Tcl_GetChannelInstanceData _ANSI_ARGS_(( Tcl_Channel chan)); /* 155 */ EXTERN int Tcl_GetChannelMode _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */ EXTERN CONST84_RETURN char * Tcl_GetChannelName _ANSI_ARGS_(( Tcl_Channel chan)); /* 157 */ EXTERN int Tcl_GetChannelOption _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, Tcl_DString * dsPtr)); /* 158 */ EXTERN Tcl_ChannelType * Tcl_GetChannelType _ANSI_ARGS_((Tcl_Channel chan)); /* 159 */ EXTERN int Tcl_GetCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 160 */ EXTERN CONST84_RETURN char * Tcl_GetCommandName _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Command command)); /* 161 */ EXTERN int Tcl_GetErrno _ANSI_ARGS_((void)); /* 162 */ EXTERN CONST84_RETURN char * Tcl_GetHostName _ANSI_ARGS_((void)); /* 163 */ EXTERN int Tcl_GetInterpPath _ANSI_ARGS_(( Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 164 */ EXTERN Tcl_Interp * Tcl_GetMaster _ANSI_ARGS_((Tcl_Interp * interp)); /* 165 */ EXTERN CONST char * Tcl_GetNameOfExecutable _ANSI_ARGS_((void)); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult _ANSI_ARGS_((Tcl_Interp * interp)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 167 */ EXTERN int Tcl_GetOpenFile _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int forWriting, int checkUsage, ClientData * filePtr)); #endif /* UNIX */ /* 168 */ EXTERN Tcl_PathType Tcl_GetPathType _ANSI_ARGS_((CONST char * path)); |
| ︙ | ︙ | |||
564 565 566 567 568 569 570 | EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void)); /* 172 */ EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName)); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type)); /* 174 */ | | > | | | | > | | 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 | EXTERN int Tcl_GetServiceMode _ANSI_ARGS_((void)); /* 172 */ EXTERN Tcl_Interp * Tcl_GetSlave _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName)); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel _ANSI_ARGS_((int type)); /* 174 */ EXTERN CONST84_RETURN char * Tcl_GetStringResult _ANSI_ARGS_(( Tcl_Interp * interp)); /* 175 */ EXTERN CONST84_RETURN char * Tcl_GetVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 176 */ EXTERN CONST84_RETURN char * Tcl_GetVar2 _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 177 */ EXTERN int Tcl_GlobalEval _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command)); /* 178 */ EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 179 */ EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST char * hiddenCmdToken)); |
| ︙ | ︙ | |||
600 601 602 603 604 605 606 | EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp * interp)); /* 186 */ EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, CONST84 char * CONST * argv, Tcl_DString * resultPtr)); /* 187 */ EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp * interp, | | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 | EXTERN int Tcl_IsSafe _ANSI_ARGS_((Tcl_Interp * interp)); /* 186 */ EXTERN char * Tcl_JoinPath _ANSI_ARGS_((int argc, CONST84 char * CONST * argv, Tcl_DString * resultPtr)); /* 187 */ EXTERN int Tcl_LinkVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, char * addr, int type)); /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel _ANSI_ARGS_((ClientData handle, int mode)); /* 190 */ EXTERN int Tcl_MakeSafe _ANSI_ARGS_((Tcl_Interp * interp)); /* 191 */ |
| ︙ | ︙ | |||
627 628 629 630 631 632 633 | EXTERN Tcl_Obj * Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, int flags)); /* 196 */ EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_Obj * newValuePtr, int flags)); | | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 | EXTERN Tcl_Obj * Tcl_ObjGetVar2 _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, int flags)); /* 196 */ EXTERN Tcl_Obj * Tcl_ObjSetVar2 _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_Obj * newValuePtr, int flags)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel _ANSI_ARGS_(( Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); #endif /* UNIX */ #ifdef __WIN32__ /* 197 */ |
| ︙ | ︙ | |||
660 661 662 663 664 665 666 | EXTERN void Tcl_Preserve _ANSI_ARGS_((ClientData data)); /* 202 */ EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 203 */ EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char * string)); /* 204 */ | | | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 | EXTERN void Tcl_Preserve _ANSI_ARGS_((ClientData data)); /* 202 */ EXTERN void Tcl_PrintDouble _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 203 */ EXTERN int Tcl_PutEnv _ANSI_ARGS_((CONST char * string)); /* 204 */ EXTERN CONST84_RETURN char * Tcl_PosixError _ANSI_ARGS_((Tcl_Interp * interp)); /* 205 */ EXTERN void Tcl_QueueEvent _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 206 */ EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 207 */ EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); #endif /* UNIX */ #ifdef __WIN32__ /* 207 */ EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void)); #endif /* __WIN32__ */ |
| ︙ | ︙ | |||
763 764 765 766 767 768 769 | /* 235 */ EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 236 */ EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 237 */ | | | | | | | | 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 | /* 235 */ EXTERN void Tcl_SetObjResult _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 236 */ EXTERN void Tcl_SetStdChannel _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 237 */ EXTERN CONST84_RETURN char * Tcl_SetVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, CONST char * newValue, int flags)); /* 238 */ EXTERN CONST84_RETURN char * Tcl_SetVar2 _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * newValue, int flags)); /* 239 */ EXTERN CONST84_RETURN char * Tcl_SignalId _ANSI_ARGS_((int sig)); /* 240 */ EXTERN CONST84_RETURN char * Tcl_SignalMsg _ANSI_ARGS_((int sig)); /* 241 */ EXTERN void Tcl_SourceRCFile _ANSI_ARGS_((Tcl_Interp * interp)); /* 242 */ EXTERN int Tcl_SplitList _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, CONST84 char *** argvPtr)); /* 243 */ |
| ︙ | ︙ | |||
795 796 797 798 799 800 801 | /* 245 */ EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 246 */ EXTERN int Tcl_TellOld _ANSI_ARGS_((Tcl_Channel chan)); /* 247 */ EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp * interp, | | | | | | | > | | | | | | | | | | 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 | /* 245 */ EXTERN int Tcl_StringMatch _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 246 */ EXTERN int Tcl_TellOld _ANSI_ARGS_((Tcl_Channel chan)); /* 247 */ EXTERN int Tcl_TraceVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */ EXTERN int Tcl_TraceVar2 _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 249 */ EXTERN char * Tcl_TranslateFileName _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, Tcl_DString * bufferPtr)); /* 250 */ EXTERN int Tcl_Ungets _ANSI_ARGS_((Tcl_Channel chan, CONST char * str, int len, int atHead)); /* 251 */ EXTERN void Tcl_UnlinkVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 252 */ EXTERN int Tcl_UnregisterChannel _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Channel chan)); /* 253 */ EXTERN int Tcl_UnsetVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 254 */ EXTERN int Tcl_UnsetVar2 _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 255 */ EXTERN void Tcl_UntraceVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */ EXTERN void Tcl_UntraceVar2 _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 257 */ EXTERN void Tcl_UpdateLinkedVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 258 */ EXTERN int Tcl_UpVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 259 */ EXTERN int Tcl_UpVar2 _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 260 */ EXTERN int Tcl_VarEval _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 261 */ EXTERN ClientData Tcl_VarTraceInfo _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */ EXTERN ClientData Tcl_VarTraceInfo2 _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 263 */ EXTERN int Tcl_Write _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 264 */ EXTERN void Tcl_WrongNumArgs _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], |
| ︙ | ︙ | |||
876 877 878 879 880 881 882 | /* 267 */ EXTERN void Tcl_AppendResultVA _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 268 */ EXTERN void Tcl_AppendStringsToObjVA _ANSI_ARGS_(( Tcl_Obj * objPtr, va_list argList)); /* 269 */ | > | | | | | > | | | | 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 | /* 267 */ EXTERN void Tcl_AppendResultVA _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 268 */ EXTERN void Tcl_AppendStringsToObjVA _ANSI_ARGS_(( Tcl_Obj * objPtr, va_list argList)); /* 269 */ EXTERN CONST84_RETURN char * Tcl_HashStats _ANSI_ARGS_(( Tcl_HashTable * tablePtr)); /* 270 */ EXTERN CONST84_RETURN char * Tcl_ParseVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST84 char ** termPtr)); /* 271 */ EXTERN CONST84_RETURN char * Tcl_PkgPresent _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 272 */ EXTERN CONST84_RETURN char * Tcl_PkgPresentEx _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 273 */ EXTERN int Tcl_PkgProvide _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version)); /* 274 */ EXTERN CONST84_RETURN char * Tcl_PkgRequire _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 275 */ EXTERN void Tcl_SetErrorCodeVA _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */ EXTERN int Tcl_VarEvalVA _ANSI_ARGS_((Tcl_Interp * interp, |
| ︙ | ︙ | |||
942 943 944 945 946 947 948 | EXTERN void Tcl_DeleteThreadExitHandler _ANSI_ARGS_(( Tcl_ExitProc * proc, ClientData clientData)); /* 290 */ EXTERN void Tcl_DiscardResult _ANSI_ARGS_(( Tcl_SavedResult * statePtr)); /* 291 */ EXTERN int Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp, | | | 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 | EXTERN void Tcl_DeleteThreadExitHandler _ANSI_ARGS_(( Tcl_ExitProc * proc, ClientData clientData)); /* 290 */ EXTERN void Tcl_DiscardResult _ANSI_ARGS_(( Tcl_SavedResult * statePtr)); /* 291 */ EXTERN int Tcl_EvalEx _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, int numBytes, int flags)); /* 292 */ EXTERN int Tcl_EvalObjv _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 293 */ EXTERN int Tcl_EvalObjEx _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 294 */ |
| ︙ | ︙ | |||
975 976 977 978 979 980 981 | EXTERN void Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); /* 300 */ EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void)); /* 301 */ EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 302 */ | | | > | 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 | EXTERN void Tcl_FreeEncoding _ANSI_ARGS_((Tcl_Encoding encoding)); /* 300 */ EXTERN Tcl_ThreadId Tcl_GetCurrentThread _ANSI_ARGS_((void)); /* 301 */ EXTERN Tcl_Encoding Tcl_GetEncoding _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 302 */ EXTERN CONST84_RETURN char * Tcl_GetEncodingName _ANSI_ARGS_(( Tcl_Encoding encoding)); /* 303 */ EXTERN void Tcl_GetEncodingNames _ANSI_ARGS_(( Tcl_Interp * interp)); /* 304 */ EXTERN int Tcl_GetIndexFromObjStruct _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, CONST VOID * tablePtr, int offset, CONST char * msg, int flags, int * indexPtr)); /* 305 */ EXTERN VOID * Tcl_GetThreadData _ANSI_ARGS_(( Tcl_ThreadDataKey * keyPtr, int size)); /* 306 */ EXTERN Tcl_Obj * Tcl_GetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 307 */ EXTERN ClientData Tcl_InitNotifier _ANSI_ARGS_((void)); /* 308 */ EXTERN void Tcl_MutexLock _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */ EXTERN void Tcl_MutexUnlock _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 310 */ |
| ︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 | EXTERN void Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 316 */ EXTERN int Tcl_SetSystemEncoding _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name)); /* 317 */ EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, | | | | | | | | 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 | EXTERN void Tcl_SaveResult _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 316 */ EXTERN int Tcl_SetSystemEncoding _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name)); /* 317 */ EXTERN Tcl_Obj * Tcl_SetVar2Ex _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 318 */ EXTERN void Tcl_ThreadAlert _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 319 */ EXTERN void Tcl_ThreadQueueEvent _ANSI_ARGS_(( Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 320 */ EXTERN Tcl_UniChar Tcl_UniCharAtIndex _ANSI_ARGS_((CONST char * src, int index)); /* 321 */ EXTERN Tcl_UniChar Tcl_UniCharToLower _ANSI_ARGS_((int ch)); /* 322 */ EXTERN Tcl_UniChar Tcl_UniCharToTitle _ANSI_ARGS_((int ch)); /* 323 */ EXTERN Tcl_UniChar Tcl_UniCharToUpper _ANSI_ARGS_((int ch)); /* 324 */ EXTERN int Tcl_UniCharToUtf _ANSI_ARGS_((int ch, char * buf)); /* 325 */ EXTERN CONST84_RETURN char * Tcl_UtfAtIndex _ANSI_ARGS_((CONST char * src, int index)); /* 326 */ EXTERN int Tcl_UtfCharComplete _ANSI_ARGS_((CONST char * src, int len)); /* 327 */ EXTERN int Tcl_UtfBackslash _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 328 */ EXTERN CONST84_RETURN char * Tcl_UtfFindFirst _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */ EXTERN CONST84_RETURN char * Tcl_UtfFindLast _ANSI_ARGS_((CONST char * src, int ch)); /* 330 */ EXTERN CONST84_RETURN char * Tcl_UtfNext _ANSI_ARGS_((CONST char * src)); /* 331 */ EXTERN CONST84_RETURN char * Tcl_UtfPrev _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 332 */ EXTERN int Tcl_UtfToExternal _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, |
| ︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 | CONST char * src, int srcLen)); /* 339 */ EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 340 */ EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 341 */ | | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 | CONST char * src, int srcLen)); /* 339 */ EXTERN int Tcl_WriteObj _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 340 */ EXTERN char * Tcl_GetString _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 341 */ EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir _ANSI_ARGS_((void)); /* 342 */ EXTERN void Tcl_SetDefaultEncodingDir _ANSI_ARGS_(( CONST char * path)); /* 343 */ EXTERN void Tcl_AlertNotifier _ANSI_ARGS_((ClientData clientData)); /* 344 */ EXTERN void Tcl_ServiceModeHook _ANSI_ARGS_((int mode)); |
| ︙ | ︙ | |||
1140 1141 1142 1143 1144 1145 1146 | EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 359 */ EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 360 */ EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, | | | | | | | | | | 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 | EXTERN void Tcl_FreeParse _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 359 */ EXTERN void Tcl_LogCommandInfo _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 360 */ EXTERN int Tcl_ParseBraces _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 361 */ EXTERN int Tcl_ParseCommand _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 362 */ EXTERN int Tcl_ParseExpr _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr)); /* 363 */ EXTERN int Tcl_ParseQuotedString _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 364 */ EXTERN int Tcl_ParseVarName _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 365 */ EXTERN char * Tcl_GetCwd _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 366 */ EXTERN int Tcl_Chdir _ANSI_ARGS_((CONST char * dirName)); /* 367 */ |
| ︙ | ︙ | |||
1251 1252 1253 1254 1255 1256 1257 | EXTERN int Tcl_WriteRaw _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 396 */ EXTERN Tcl_Channel Tcl_GetTopChannel _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */ EXTERN int Tcl_ChannelBuffered _ANSI_ARGS_((Tcl_Channel chan)); /* 398 */ | | | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 | EXTERN int Tcl_WriteRaw _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 396 */ EXTERN Tcl_Channel Tcl_GetTopChannel _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */ EXTERN int Tcl_ChannelBuffered _ANSI_ARGS_((Tcl_Channel chan)); /* 398 */ EXTERN CONST84_RETURN char * Tcl_ChannelName _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); /* 399 */ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); /* 400 */ EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); |
| ︙ | ︙ | |||
1403 1404 1405 1406 1407 1408 1409 | EXTERN int Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 444 */ EXTERN int Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, | | | | 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 | EXTERN int Tcl_FSDeleteFile _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 444 */ EXTERN int Tcl_FSLoadFile _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, Tcl_LoadHandle * handlePtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 445 */ EXTERN int Tcl_FSMatchInDirectory _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 446 */ EXTERN Tcl_Obj * Tcl_FSLink _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr, int linkAction)); /* 447 */ EXTERN int Tcl_FSRemoveDirectory _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 448 */ EXTERN int Tcl_FSRenameFile _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 449 */ |
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 | EXTERN Tcl_Obj* Tcl_FSGetTranslatedPath _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 467 */ EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 468 */ EXTERN Tcl_Obj* Tcl_FSNewNativePath _ANSI_ARGS_(( | | | 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 | EXTERN Tcl_Obj* Tcl_FSGetTranslatedPath _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 467 */ EXTERN int Tcl_FSEvalFile _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 468 */ EXTERN Tcl_Obj* Tcl_FSNewNativePath _ANSI_ARGS_(( Tcl_Filesystem* fromFilesystem, ClientData clientData)); /* 469 */ EXTERN CONST char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */ EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_(( Tcl_Obj* pathObjPtr)); /* 471 */ |
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 |
} TclStubHooks;
typedef struct TclStubs {
int magic;
struct TclStubHooks *hooks;
int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
| | | | | 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 |
} TclStubHooks;
typedef struct TclStubs {
int magic;
struct TclStubHooks *hooks;
int (*tcl_PkgProvideEx) _ANSI_ARGS_((Tcl_Interp* interp, CONST char* name, CONST char* version, ClientData clientData)); /* 0 */
CONST84_RETURN char * (*tcl_PkgRequireEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 1 */
void (*tcl_Panic) _ANSI_ARGS_(TCL_VARARGS(CONST char *,format)); /* 2 */
char * (*tcl_Alloc) _ANSI_ARGS_((unsigned int size)); /* 3 */
void (*tcl_Free) _ANSI_ARGS_((char * ptr)); /* 4 */
char * (*tcl_Realloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 5 */
char * (*tcl_DbCkalloc) _ANSI_ARGS_((unsigned int size, CONST char * file, int line)); /* 6 */
int (*tcl_DbCkfree) _ANSI_ARGS_((char * ptr, CONST char * file, int line)); /* 7 */
char * (*tcl_DbCkrealloc) _ANSI_ARGS_((char * ptr, unsigned int size, CONST char * file, int line)); /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
void (*tcl_CreateFileHandler) _ANSI_ARGS_((int fd, int mask, Tcl_FileProc * proc, ClientData clientData)); /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
void *reserved9;
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved9;
#endif /* MAC_TCL */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
void (*tcl_DeleteFileHandler) _ANSI_ARGS_((int fd)); /* 10 */
#endif /* UNIX */
#ifdef __WIN32__
void *reserved10;
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved10;
|
| ︙ | ︙ | |||
1661 1662 1663 1664 1665 1666 1667 |
int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * optionName, CONST char * optionList)); /* 78 */
void (*tcl_CallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 79 */
void (*tcl_CancelIdleCall) _ANSI_ARGS_((Tcl_IdleProc * idleProc, ClientData clientData)); /* 80 */
int (*tcl_Close) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 81 */
| | | | 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
int (*tcl_AsyncReady) _ANSI_ARGS_((void)); /* 75 */
void (*tcl_BackgroundError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 76 */
char (*tcl_Backslash) _ANSI_ARGS_((CONST char * src, int * readPtr)); /* 77 */
int (*tcl_BadChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * optionName, CONST char * optionList)); /* 78 */
void (*tcl_CallWhenDeleted) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_InterpDeleteProc * proc, ClientData clientData)); /* 79 */
void (*tcl_CancelIdleCall) _ANSI_ARGS_((Tcl_IdleProc * idleProc, ClientData clientData)); /* 80 */
int (*tcl_Close) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 81 */
int (*tcl_CommandComplete) _ANSI_ARGS_((CONST char * cmd)); /* 82 */
char * (*tcl_Concat) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 83 */
int (*tcl_ConvertElement) _ANSI_ARGS_((CONST char * src, char * dst, int flags)); /* 84 */
int (*tcl_ConvertCountedElement) _ANSI_ARGS_((CONST char * src, int length, char * dst, int flags)); /* 85 */
int (*tcl_CreateAlias) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int argc, CONST84 char * CONST * argv)); /* 86 */
int (*tcl_CreateAliasObj) _ANSI_ARGS_((Tcl_Interp * slave, CONST char * slaveCmd, Tcl_Interp * target, CONST char * targetCmd, int objc, Tcl_Obj *CONST objv[])); /* 87 */
Tcl_Channel (*tcl_CreateChannel) _ANSI_ARGS_((Tcl_ChannelType * typePtr, CONST char * chanName, ClientData instanceData, int mask)); /* 88 */
void (*tcl_CreateChannelHandler) _ANSI_ARGS_((Tcl_Channel chan, int mask, Tcl_ChannelProc * proc, ClientData clientData)); /* 89 */
void (*tcl_CreateCloseHandler) _ANSI_ARGS_((Tcl_Channel chan, Tcl_CloseProc * proc, ClientData clientData)); /* 90 */
Tcl_Command (*tcl_CreateCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdProc * proc, ClientData clientData, Tcl_CmdDeleteProc * deleteProc)); /* 91 */
void (*tcl_CreateEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 92 */
void (*tcl_CreateExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 93 */
|
| ︙ | ︙ | |||
1690 1691 1692 1693 1694 1695 1696 |
int (*tcl_DeleteCommandFromToken) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 104 */
void (*tcl_DeleteEvents) _ANSI_ARGS_((Tcl_EventDeleteProc * proc, ClientData clientData)); /* 105 */
void (*tcl_DeleteEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 106 */
void (*tcl_DeleteExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 107 */
void (*tcl_DeleteHashEntry) _ANSI_ARGS_((Tcl_HashEntry * entryPtr)); /* 108 */
void (*tcl_DeleteHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 109 */
void (*tcl_DeleteInterp) _ANSI_ARGS_((Tcl_Interp * interp)); /* 110 */
| | | 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 |
int (*tcl_DeleteCommandFromToken) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 104 */
void (*tcl_DeleteEvents) _ANSI_ARGS_((Tcl_EventDeleteProc * proc, ClientData clientData)); /* 105 */
void (*tcl_DeleteEventSource) _ANSI_ARGS_((Tcl_EventSetupProc * setupProc, Tcl_EventCheckProc * checkProc, ClientData clientData)); /* 106 */
void (*tcl_DeleteExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 107 */
void (*tcl_DeleteHashEntry) _ANSI_ARGS_((Tcl_HashEntry * entryPtr)); /* 108 */
void (*tcl_DeleteHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 109 */
void (*tcl_DeleteInterp) _ANSI_ARGS_((Tcl_Interp * interp)); /* 110 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
#endif /* UNIX */
#ifdef __WIN32__
void (*tcl_DetachPids) _ANSI_ARGS_((int numPids, Tcl_Pid * pidPtr)); /* 111 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved111;
|
| ︙ | ︙ | |||
1714 1715 1716 1717 1718 1719 1720 |
void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */
void (*tcl_DStringGetResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 121 */
void (*tcl_DStringInit) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 122 */
void (*tcl_DStringResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 123 */
void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString * dsPtr, int length)); /* 124 */
void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 125 */
int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */
| | | | | | | | | | | | | | | | | | 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 |
void (*tcl_DStringFree) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 120 */
void (*tcl_DStringGetResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 121 */
void (*tcl_DStringInit) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 122 */
void (*tcl_DStringResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * dsPtr)); /* 123 */
void (*tcl_DStringSetLength) _ANSI_ARGS_((Tcl_DString * dsPtr, int length)); /* 124 */
void (*tcl_DStringStartSublist) _ANSI_ARGS_((Tcl_DString * dsPtr)); /* 125 */
int (*tcl_Eof) _ANSI_ARGS_((Tcl_Channel chan)); /* 126 */
CONST84_RETURN char * (*tcl_ErrnoId) _ANSI_ARGS_((void)); /* 127 */
CONST84_RETURN char * (*tcl_ErrnoMsg) _ANSI_ARGS_((int err)); /* 128 */
int (*tcl_Eval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 129 */
int (*tcl_EvalFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName)); /* 130 */
int (*tcl_EvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 131 */
void (*tcl_EventuallyFree) _ANSI_ARGS_((ClientData clientData, Tcl_FreeProc * freeProc)); /* 132 */
void (*tcl_Exit) _ANSI_ARGS_((int status)); /* 133 */
int (*tcl_ExposeCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * hiddenCmdToken, CONST char * cmdName)); /* 134 */
int (*tcl_ExprBoolean) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * ptr)); /* 135 */
int (*tcl_ExprBooleanObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int * ptr)); /* 136 */
int (*tcl_ExprDouble) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, double * ptr)); /* 137 */
int (*tcl_ExprDoubleObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, double * ptr)); /* 138 */
int (*tcl_ExprLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * ptr)); /* 139 */
int (*tcl_ExprLongObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, long * ptr)); /* 140 */
int (*tcl_ExprObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, Tcl_Obj ** resultPtrPtr)); /* 141 */
int (*tcl_ExprString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string)); /* 142 */
void (*tcl_Finalize) _ANSI_ARGS_((void)); /* 143 */
void (*tcl_FindExecutable) _ANSI_ARGS_((CONST char * argv0)); /* 144 */
Tcl_HashEntry * (*tcl_FirstHashEntry) _ANSI_ARGS_((Tcl_HashTable * tablePtr, Tcl_HashSearch * searchPtr)); /* 145 */
int (*tcl_Flush) _ANSI_ARGS_((Tcl_Channel chan)); /* 146 */
void (*tcl_FreeResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 147 */
int (*tcl_GetAlias) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * argcPtr, CONST84 char *** argvPtr)); /* 148 */
int (*tcl_GetAliasObj) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveCmd, Tcl_Interp ** targetInterpPtr, CONST84 char ** targetCmdPtr, int * objcPtr, Tcl_Obj *** objv)); /* 149 */
ClientData (*tcl_GetAssocData) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_InterpDeleteProc ** procPtr)); /* 150 */
Tcl_Channel (*tcl_GetChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * chanName, int * modePtr)); /* 151 */
int (*tcl_GetChannelBufferSize) _ANSI_ARGS_((Tcl_Channel chan)); /* 152 */
int (*tcl_GetChannelHandle) _ANSI_ARGS_((Tcl_Channel chan, int direction, ClientData * handlePtr)); /* 153 */
ClientData (*tcl_GetChannelInstanceData) _ANSI_ARGS_((Tcl_Channel chan)); /* 154 */
int (*tcl_GetChannelMode) _ANSI_ARGS_((Tcl_Channel chan)); /* 155 */
CONST84_RETURN char * (*tcl_GetChannelName) _ANSI_ARGS_((Tcl_Channel chan)); /* 156 */
int (*tcl_GetChannelOption) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, CONST char * optionName, Tcl_DString * dsPtr)); /* 157 */
Tcl_ChannelType * (*tcl_GetChannelType) _ANSI_ARGS_((Tcl_Channel chan)); /* 158 */
int (*tcl_GetCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, Tcl_CmdInfo * infoPtr)); /* 159 */
CONST84_RETURN char * (*tcl_GetCommandName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command)); /* 160 */
int (*tcl_GetErrno) _ANSI_ARGS_((void)); /* 161 */
CONST84_RETURN char * (*tcl_GetHostName) _ANSI_ARGS_((void)); /* 162 */
int (*tcl_GetInterpPath) _ANSI_ARGS_((Tcl_Interp * askInterp, Tcl_Interp * slaveInterp)); /* 163 */
Tcl_Interp * (*tcl_GetMaster) _ANSI_ARGS_((Tcl_Interp * interp)); /* 164 */
CONST char * (*tcl_GetNameOfExecutable) _ANSI_ARGS_((void)); /* 165 */
Tcl_Obj * (*tcl_GetObjResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 166 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
int (*tcl_GetOpenFile) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int forWriting, int checkUsage, ClientData * filePtr)); /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
void *reserved167;
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved167;
#endif /* MAC_TCL */
Tcl_PathType (*tcl_GetPathType) _ANSI_ARGS_((CONST char * path)); /* 168 */
int (*tcl_Gets) _ANSI_ARGS_((Tcl_Channel chan, Tcl_DString * dsPtr)); /* 169 */
int (*tcl_GetsObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 170 */
int (*tcl_GetServiceMode) _ANSI_ARGS_((void)); /* 171 */
Tcl_Interp * (*tcl_GetSlave) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * slaveName)); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) _ANSI_ARGS_((int type)); /* 173 */
CONST84_RETURN char * (*tcl_GetStringResult) _ANSI_ARGS_((Tcl_Interp * interp)); /* 174 */
CONST84_RETURN char * (*tcl_GetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 175 */
CONST84_RETURN char * (*tcl_GetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 176 */
int (*tcl_GlobalEval) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * command)); /* 177 */
int (*tcl_GlobalEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 178 */
int (*tcl_HideCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * cmdName, CONST char * hiddenCmdToken)); /* 179 */
int (*tcl_Init) _ANSI_ARGS_((Tcl_Interp * interp)); /* 180 */
void (*tcl_InitHashTable) _ANSI_ARGS_((Tcl_HashTable * tablePtr, int keyType)); /* 181 */
int (*tcl_InputBlocked) _ANSI_ARGS_((Tcl_Channel chan)); /* 182 */
int (*tcl_InputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 183 */
int (*tcl_InterpDeleted) _ANSI_ARGS_((Tcl_Interp * interp)); /* 184 */
int (*tcl_IsSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 185 */
char * (*tcl_JoinPath) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv, Tcl_DString * resultPtr)); /* 186 */
int (*tcl_LinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, char * addr, int type)); /* 187 */
void *reserved188;
Tcl_Channel (*tcl_MakeFileChannel) _ANSI_ARGS_((ClientData handle, int mode)); /* 189 */
int (*tcl_MakeSafe) _ANSI_ARGS_((Tcl_Interp * interp)); /* 190 */
Tcl_Channel (*tcl_MakeTcpClientChannel) _ANSI_ARGS_((ClientData tcpSocket)); /* 191 */
char * (*tcl_Merge) _ANSI_ARGS_((int argc, CONST84 char * CONST * argv)); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) _ANSI_ARGS_((Tcl_HashSearch * searchPtr)); /* 193 */
void (*tcl_NotifyChannel) _ANSI_ARGS_((Tcl_Channel channel, int mask)); /* 194 */
Tcl_Obj * (*tcl_ObjGetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, int flags)); /* 195 */
Tcl_Obj * (*tcl_ObjSetVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, Tcl_Obj * newValuePtr, int flags)); /* 196 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* UNIX */
#ifdef __WIN32__
Tcl_Channel (*tcl_OpenCommandChannel) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 197 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved197;
#endif /* MAC_TCL */
Tcl_Channel (*tcl_OpenFileChannel) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * fileName, CONST char * modeString, int permissions)); /* 198 */
Tcl_Channel (*tcl_OpenTcpClient) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * address, CONST char * myaddr, int myport, int async)); /* 199 */
Tcl_Channel (*tcl_OpenTcpServer) _ANSI_ARGS_((Tcl_Interp * interp, int port, CONST char * host, Tcl_TcpAcceptProc * acceptProc, ClientData callbackData)); /* 200 */
void (*tcl_Preserve) _ANSI_ARGS_((ClientData data)); /* 201 */
void (*tcl_PrintDouble) _ANSI_ARGS_((Tcl_Interp * interp, double value, char * dst)); /* 202 */
int (*tcl_PutEnv) _ANSI_ARGS_((CONST char * string)); /* 203 */
CONST84_RETURN char * (*tcl_PosixError) _ANSI_ARGS_((Tcl_Interp * interp)); /* 204 */
void (*tcl_QueueEvent) _ANSI_ARGS_((Tcl_Event * evPtr, Tcl_QueuePosition position)); /* 205 */
int (*tcl_Read) _ANSI_ARGS_((Tcl_Channel chan, char * bufPtr, int toRead)); /* 206 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* UNIX */
#ifdef __WIN32__
void (*tcl_ReapDetachedProcs) _ANSI_ARGS_((void)); /* 207 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved207;
|
| ︙ | ︙ | |||
1848 1849 1850 1851 1852 1853 1854 |
void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */
int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
void (*tcl_SetPanicProc) _ANSI_ARGS_((Tcl_PanicProc * panicProc)); /* 230 */
int (*tcl_SetRecursionLimit) _ANSI_ARGS_((Tcl_Interp * interp, int depth)); /* 231 */
void (*tcl_SetResult) _ANSI_ARGS_((Tcl_Interp * interp, char * str, Tcl_FreeProc * freeProc)); /* 232 */
int (*tcl_SetServiceMode) _ANSI_ARGS_((int mode)); /* 233 */
void (*tcl_SetObjErrorCode) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * errorObjPtr)); /* 234 */
void (*tcl_SetObjResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * resultObjPtr)); /* 235 */
void (*tcl_SetStdChannel) _ANSI_ARGS_((Tcl_Channel channel, int type)); /* 236 */
CONST84_RETURN char * (*tcl_SetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, CONST char * newValue, int flags)); /* 237 */
CONST84_RETURN char * (*tcl_SetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, CONST char * newValue, int flags)); /* 238 */
CONST84_RETURN char * (*tcl_SignalId) _ANSI_ARGS_((int sig)); /* 239 */
CONST84_RETURN char * (*tcl_SignalMsg) _ANSI_ARGS_((int sig)); /* 240 */
void (*tcl_SourceRCFile) _ANSI_ARGS_((Tcl_Interp * interp)); /* 241 */
int (*tcl_SplitList) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * listStr, int * argcPtr, CONST84 char *** argvPtr)); /* 242 */
void (*tcl_SplitPath) _ANSI_ARGS_((CONST char * path, int * argcPtr, CONST84 char *** argvPtr)); /* 243 */
void (*tcl_StaticPackage) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * pkgName, Tcl_PackageInitProc * initProc, Tcl_PackageInitProc * safeInitProc)); /* 244 */
int (*tcl_StringMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern)); /* 245 */
int (*tcl_TellOld) _ANSI_ARGS_((Tcl_Channel chan)); /* 246 */
int (*tcl_TraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 247 */
int (*tcl_TraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 248 */
char * (*tcl_TranslateFileName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_DString * bufferPtr)); /* 249 */
int (*tcl_Ungets) _ANSI_ARGS_((Tcl_Channel chan, CONST char * str, int len, int atHead)); /* 250 */
void (*tcl_UnlinkVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 251 */
int (*tcl_UnregisterChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 252 */
int (*tcl_UnsetVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags)); /* 253 */
int (*tcl_UnsetVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 254 */
void (*tcl_UntraceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 255 */
void (*tcl_UntraceVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * proc, ClientData clientData)); /* 256 */
void (*tcl_UpdateLinkedVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 257 */
int (*tcl_UpVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * varName, CONST char * localName, int flags)); /* 258 */
int (*tcl_UpVar2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * frameName, CONST char * part1, CONST char * part2, CONST char * localName, int flags)); /* 259 */
int (*tcl_VarEval) _ANSI_ARGS_(TCL_VARARGS(Tcl_Interp *,interp)); /* 260 */
ClientData (*tcl_VarTraceInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 261 */
ClientData (*tcl_VarTraceInfo2) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, Tcl_VarTraceProc * procPtr, ClientData prevClientData)); /* 262 */
int (*tcl_Write) _ANSI_ARGS_((Tcl_Channel chan, CONST char * s, int slen)); /* 263 */
void (*tcl_WrongNumArgs) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], CONST char * message)); /* 264 */
int (*tcl_DumpActiveMemory) _ANSI_ARGS_((CONST char * fileName)); /* 265 */
void (*tcl_ValidateAllMemory) _ANSI_ARGS_((CONST char * file, int line)); /* 266 */
void (*tcl_AppendResultVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 267 */
void (*tcl_AppendStringsToObjVA) _ANSI_ARGS_((Tcl_Obj * objPtr, va_list argList)); /* 268 */
CONST84_RETURN char * (*tcl_HashStats) _ANSI_ARGS_((Tcl_HashTable * tablePtr)); /* 269 */
CONST84_RETURN char * (*tcl_ParseVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CONST84 char ** termPtr)); /* 270 */
CONST84_RETURN char * (*tcl_PkgPresent) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 271 */
CONST84_RETURN char * (*tcl_PkgPresentEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact, ClientData * clientDataPtr)); /* 272 */
int (*tcl_PkgProvide) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version)); /* 273 */
CONST84_RETURN char * (*tcl_PkgRequire) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, CONST char * version, int exact)); /* 274 */
void (*tcl_SetErrorCodeVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 275 */
int (*tcl_VarEvalVA) _ANSI_ARGS_((Tcl_Interp * interp, va_list argList)); /* 276 */
Tcl_Pid (*tcl_WaitPid) _ANSI_ARGS_((Tcl_Pid pid, int * statPtr, int options)); /* 277 */
void (*tcl_PanicVA) _ANSI_ARGS_((CONST char * format, va_list argList)); /* 278 */
void (*tcl_GetVersion) _ANSI_ARGS_((int * major, int * minor, int * patchLevel, int * type)); /* 279 */
void (*tcl_InitMemory) _ANSI_ARGS_((Tcl_Interp * interp)); /* 280 */
Tcl_Channel (*tcl_StackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_ChannelType * typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan)); /* 281 */
int (*tcl_UnstackChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 283 */
void (*tcl_SetMainLoop) _ANSI_ARGS_((Tcl_MainLoopProc * proc)); /* 284 */
void *reserved285;
void (*tcl_AppendObjToObj) _ANSI_ARGS_((Tcl_Obj * objPtr, Tcl_Obj * appendObjPtr)); /* 286 */
Tcl_Encoding (*tcl_CreateEncoding) _ANSI_ARGS_((Tcl_EncodingType * typePtr)); /* 287 */
void (*tcl_CreateThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 288 */
void (*tcl_DeleteThreadExitHandler) _ANSI_ARGS_((Tcl_ExitProc * proc, ClientData clientData)); /* 289 */
void (*tcl_DiscardResult) _ANSI_ARGS_((Tcl_SavedResult * statePtr)); /* 290 */
int (*tcl_EvalEx) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, int numBytes, int flags)); /* 291 */
int (*tcl_EvalObjv) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 292 */
int (*tcl_EvalObjEx) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 293 */
void (*tcl_ExitThread) _ANSI_ARGS_((int status)); /* 294 */
int (*tcl_ExternalToUtf) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 295 */
char * (*tcl_ExternalToUtfDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 296 */
void (*tcl_FinalizeThread) _ANSI_ARGS_((void)); /* 297 */
void (*tcl_FinalizeNotifier) _ANSI_ARGS_((ClientData clientData)); /* 298 */
void (*tcl_FreeEncoding) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 299 */
Tcl_ThreadId (*tcl_GetCurrentThread) _ANSI_ARGS_((void)); /* 300 */
Tcl_Encoding (*tcl_GetEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 301 */
CONST84_RETURN char * (*tcl_GetEncodingName) _ANSI_ARGS_((Tcl_Encoding encoding)); /* 302 */
void (*tcl_GetEncodingNames) _ANSI_ARGS_((Tcl_Interp * interp)); /* 303 */
int (*tcl_GetIndexFromObjStruct) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CONST VOID * tablePtr, int offset, CONST char * msg, int flags, int * indexPtr)); /* 304 */
VOID * (*tcl_GetThreadData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr, int size)); /* 305 */
Tcl_Obj * (*tcl_GetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags)); /* 306 */
ClientData (*tcl_InitNotifier) _ANSI_ARGS_((void)); /* 307 */
void (*tcl_MutexLock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 308 */
void (*tcl_MutexUnlock) _ANSI_ARGS_((Tcl_Mutex * mutexPtr)); /* 309 */
void (*tcl_ConditionNotify) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 310 */
void (*tcl_ConditionWait) _ANSI_ARGS_((Tcl_Condition * condPtr, Tcl_Mutex * mutexPtr, Tcl_Time * timePtr)); /* 311 */
int (*tcl_NumUtfChars) _ANSI_ARGS_((CONST char * src, int len)); /* 312 */
int (*tcl_ReadChars) _ANSI_ARGS_((Tcl_Channel channel, Tcl_Obj * objPtr, int charsToRead, int appendFlag)); /* 313 */
void (*tcl_RestoreResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 314 */
void (*tcl_SaveResult) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_SavedResult * statePtr)); /* 315 */
int (*tcl_SetSystemEncoding) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 316 */
Tcl_Obj * (*tcl_SetVar2Ex) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, Tcl_Obj * newValuePtr, int flags)); /* 317 */
void (*tcl_ThreadAlert) _ANSI_ARGS_((Tcl_ThreadId threadId)); /* 318 */
void (*tcl_ThreadQueueEvent) _ANSI_ARGS_((Tcl_ThreadId threadId, Tcl_Event* evPtr, Tcl_QueuePosition position)); /* 319 */
Tcl_UniChar (*tcl_UniCharAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 320 */
Tcl_UniChar (*tcl_UniCharToLower) _ANSI_ARGS_((int ch)); /* 321 */
Tcl_UniChar (*tcl_UniCharToTitle) _ANSI_ARGS_((int ch)); /* 322 */
Tcl_UniChar (*tcl_UniCharToUpper) _ANSI_ARGS_((int ch)); /* 323 */
int (*tcl_UniCharToUtf) _ANSI_ARGS_((int ch, char * buf)); /* 324 */
CONST84_RETURN char * (*tcl_UtfAtIndex) _ANSI_ARGS_((CONST char * src, int index)); /* 325 */
int (*tcl_UtfCharComplete) _ANSI_ARGS_((CONST char * src, int len)); /* 326 */
int (*tcl_UtfBackslash) _ANSI_ARGS_((CONST char * src, int * readPtr, char * dst)); /* 327 */
CONST84_RETURN char * (*tcl_UtfFindFirst) _ANSI_ARGS_((CONST char * src, int ch)); /* 328 */
CONST84_RETURN char * (*tcl_UtfFindLast) _ANSI_ARGS_((CONST char * src, int ch)); /* 329 */
CONST84_RETURN char * (*tcl_UtfNext) _ANSI_ARGS_((CONST char * src)); /* 330 */
CONST84_RETURN char * (*tcl_UtfPrev) _ANSI_ARGS_((CONST char * src, CONST char * start)); /* 331 */
int (*tcl_UtfToExternal) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr)); /* 332 */
char * (*tcl_UtfToExternalDString) _ANSI_ARGS_((Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr)); /* 333 */
int (*tcl_UtfToLower) _ANSI_ARGS_((char * src)); /* 334 */
int (*tcl_UtfToTitle) _ANSI_ARGS_((char * src)); /* 335 */
int (*tcl_UtfToUniChar) _ANSI_ARGS_((CONST char * src, Tcl_UniChar * chPtr)); /* 336 */
int (*tcl_UtfToUpper) _ANSI_ARGS_((char * src)); /* 337 */
int (*tcl_WriteChars) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 338 */
int (*tcl_WriteObj) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj * objPtr)); /* 339 */
char * (*tcl_GetString) _ANSI_ARGS_((Tcl_Obj * objPtr)); /* 340 */
CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) _ANSI_ARGS_((void)); /* 341 */
void (*tcl_SetDefaultEncodingDir) _ANSI_ARGS_((CONST char * path)); /* 342 */
void (*tcl_AlertNotifier) _ANSI_ARGS_((ClientData clientData)); /* 343 */
void (*tcl_ServiceModeHook) _ANSI_ARGS_((int mode)); /* 344 */
int (*tcl_UniCharIsAlnum) _ANSI_ARGS_((int ch)); /* 345 */
int (*tcl_UniCharIsAlpha) _ANSI_ARGS_((int ch)); /* 346 */
int (*tcl_UniCharIsDigit) _ANSI_ARGS_((int ch)); /* 347 */
int (*tcl_UniCharIsLower) _ANSI_ARGS_((int ch)); /* 348 */
int (*tcl_UniCharIsSpace) _ANSI_ARGS_((int ch)); /* 349 */
int (*tcl_UniCharIsUpper) _ANSI_ARGS_((int ch)); /* 350 */
int (*tcl_UniCharIsWordChar) _ANSI_ARGS_((int ch)); /* 351 */
int (*tcl_UniCharLen) _ANSI_ARGS_((CONST Tcl_UniChar * str)); /* 352 */
int (*tcl_UniCharNcmp) _ANSI_ARGS_((CONST Tcl_UniChar * cs, CONST Tcl_UniChar * ct, unsigned long n)); /* 353 */
char * (*tcl_UniCharToUtfDString) _ANSI_ARGS_((CONST Tcl_UniChar * string, int numChars, Tcl_DString * dsPtr)); /* 354 */
Tcl_UniChar * (*tcl_UtfToUniCharDString) _ANSI_ARGS_((CONST char * string, int length, Tcl_DString * dsPtr)); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * patObj, int flags)); /* 356 */
Tcl_Obj * (*tcl_EvalTokens) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 357 */
void (*tcl_FreeParse) _ANSI_ARGS_((Tcl_Parse * parsePtr)); /* 358 */
void (*tcl_LogCommandInfo) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * script, CONST char * command, int length)); /* 359 */
int (*tcl_ParseBraces) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 360 */
int (*tcl_ParseCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, int nested, Tcl_Parse * parsePtr)); /* 361 */
int (*tcl_ParseExpr) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr)); /* 362 */
int (*tcl_ParseQuotedString) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append, CONST84 char ** termPtr)); /* 363 */
int (*tcl_ParseVarName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * string, int numBytes, Tcl_Parse * parsePtr, int append)); /* 364 */
char * (*tcl_GetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 365 */
int (*tcl_Chdir) _ANSI_ARGS_((CONST char * dirName)); /* 366 */
int (*tcl_Access) _ANSI_ARGS_((CONST char * path, int mode)); /* 367 */
int (*tcl_Stat) _ANSI_ARGS_((CONST char * path, struct stat * bufPtr)); /* 368 */
int (*tcl_UtfNcmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 369 */
int (*tcl_UtfNcasecmp) _ANSI_ARGS_((CONST char * s1, CONST char * s2, unsigned long n)); /* 370 */
int (*tcl_StringCaseMatch) _ANSI_ARGS_((CONST char * str, CONST char * pattern, int nocase)); /* 371 */
|
| ︙ | ︙ | |||
2009 2010 2011 2012 2013 2014 2015 |
void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */
void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */
int (*tcl_CreateThread) _ANSI_ARGS_((Tcl_ThreadId * idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags)); /* 393 */
int (*tcl_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char * dst, int bytesToRead)); /* 394 */
int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 396 */
int (*tcl_ChannelBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */
| | | 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 |
void (*tcl_ConditionFinalize) _ANSI_ARGS_((Tcl_Condition * condPtr)); /* 391 */
void (*tcl_MutexFinalize) _ANSI_ARGS_((Tcl_Mutex * mutex)); /* 392 */
int (*tcl_CreateThread) _ANSI_ARGS_((Tcl_ThreadId * idPtr, Tcl_ThreadCreateProc proc, ClientData clientData, int stackSize, int flags)); /* 393 */
int (*tcl_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char * dst, int bytesToRead)); /* 394 */
int (*tcl_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, CONST char * src, int srcLen)); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); /* 396 */
int (*tcl_ChannelBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 397 */
CONST84_RETURN char * (*tcl_ChannelName) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 400 */
Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 401 */
Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 402 */
Tcl_DriverInputProc * (*tcl_ChannelInputProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 403 */
Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 404 */
Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 405 */
|
| ︙ | ︙ | |||
2055 2056 2057 2058 2059 2060 2061 |
Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */
int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 438 */
int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */
int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 440 */
int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 441 */
int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 442 */
int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */
| | | | 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 |
Tcl_Obj * (*tcl_SubstObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int flags)); /* 437 */
int (*tcl_DetachChannel) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Channel channel)); /* 438 */
int (*tcl_IsStandardChannel) _ANSI_ARGS_((Tcl_Channel channel)); /* 439 */
int (*tcl_FSCopyFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 440 */
int (*tcl_FSCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 441 */
int (*tcl_FSCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 442 */
int (*tcl_FSDeleteFile) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 443 */
int (*tcl_FSLoadFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * pathPtr, CONST char * sym1, CONST char * sym2, Tcl_PackageInitProc ** proc1Ptr, Tcl_PackageInitProc ** proc2Ptr, Tcl_LoadHandle * handlePtr, Tcl_FSUnloadFileProc ** unloadProcPtr)); /* 444 */
int (*tcl_FSMatchInDirectory) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * result, Tcl_Obj * pathPtr, CONST char * pattern, Tcl_GlobTypeData * types)); /* 445 */
Tcl_Obj * (*tcl_FSLink) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj * toPtr, int linkAction)); /* 446 */
int (*tcl_FSRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 447 */
int (*tcl_FSRenameFile) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr)); /* 448 */
int (*tcl_FSLstat) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_StatBuf * buf)); /* 449 */
int (*tcl_FSUtime) _ANSI_ARGS_((Tcl_Obj * pathPtr, struct utimbuf * tval)); /* 450 */
int (*tcl_FSFileAttrsGet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 451 */
int (*tcl_FSFileAttrsSet) _ANSI_ARGS_((Tcl_Interp * interp, int index, Tcl_Obj * pathPtr, Tcl_Obj * objPtr)); /* 452 */
CONST char ** (*tcl_FSFileAttrStrings) _ANSI_ARGS_((Tcl_Obj * pathPtr, Tcl_Obj ** objPtrRef)); /* 453 */
|
| ︙ | ︙ | |||
2079 2080 2081 2082 2083 2084 2085 |
Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */
int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */
Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */
Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */
Tcl_Obj* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */
int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */
| | | 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 |
Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */
int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */
Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */
Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */
Tcl_Obj* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */
int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */
Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Filesystem* fromFilesystem, ClientData clientData)); /* 468 */
CONST char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */
Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */
Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */
Tcl_Obj* (*tcl_FSListVolumes) _ANSI_ARGS_((void)); /* 472 */
int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */
int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */
ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */
|
| ︙ | ︙ | |||
2157 2158 2159 2160 2161 2162 2163 | #define Tcl_DbCkfree \ (tclStubsPtr->tcl_DbCkfree) /* 7 */ #endif #ifndef Tcl_DbCkrealloc #define Tcl_DbCkrealloc \ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ #endif | | | | 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 | #define Tcl_DbCkfree \ (tclStubsPtr->tcl_DbCkfree) /* 7 */ #endif #ifndef Tcl_DbCkrealloc #define Tcl_DbCkrealloc \ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_CreateFileHandler #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ #endif #endif /* UNIX */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_DeleteFileHandler #define Tcl_DeleteFileHandler \ (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ #endif #endif /* UNIX */ #ifndef Tcl_SetTimer #define Tcl_SetTimer \ |
| ︙ | ︙ | |||
2569 2570 2571 2572 2573 2574 2575 | #define Tcl_DeleteHashTable \ (tclStubsPtr->tcl_DeleteHashTable) /* 109 */ #endif #ifndef Tcl_DeleteInterp #define Tcl_DeleteInterp \ (tclStubsPtr->tcl_DeleteInterp) /* 110 */ #endif | | | 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 | #define Tcl_DeleteHashTable \ (tclStubsPtr->tcl_DeleteHashTable) /* 109 */ #endif #ifndef Tcl_DeleteInterp #define Tcl_DeleteInterp \ (tclStubsPtr->tcl_DeleteInterp) /* 110 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_DetachPids #define Tcl_DetachPids \ (tclStubsPtr->tcl_DetachPids) /* 111 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef Tcl_DetachPids |
| ︙ | ︙ | |||
2801 2802 2803 2804 2805 2806 2807 | #define Tcl_GetNameOfExecutable \ (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #endif #ifndef Tcl_GetObjResult #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ #endif | | | 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 | #define Tcl_GetNameOfExecutable \ (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #endif #ifndef Tcl_GetObjResult #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_GetOpenFile #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ #endif #endif /* UNIX */ #ifndef Tcl_GetPathType #define Tcl_GetPathType \ |
| ︙ | ︙ | |||
2920 2921 2922 2923 2924 2925 2926 | #define Tcl_ObjGetVar2 \ (tclStubsPtr->tcl_ObjGetVar2) /* 195 */ #endif #ifndef Tcl_ObjSetVar2 #define Tcl_ObjSetVar2 \ (tclStubsPtr->tcl_ObjSetVar2) /* 196 */ #endif | | | 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 | #define Tcl_ObjGetVar2 \ (tclStubsPtr->tcl_ObjGetVar2) /* 195 */ #endif #ifndef Tcl_ObjSetVar2 #define Tcl_ObjSetVar2 \ (tclStubsPtr->tcl_ObjSetVar2) /* 196 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_OpenCommandChannel #define Tcl_OpenCommandChannel \ (tclStubsPtr->tcl_OpenCommandChannel) /* 197 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef Tcl_OpenCommandChannel |
| ︙ | ︙ | |||
2968 2969 2970 2971 2972 2973 2974 | #define Tcl_QueueEvent \ (tclStubsPtr->tcl_QueueEvent) /* 205 */ #endif #ifndef Tcl_Read #define Tcl_Read \ (tclStubsPtr->tcl_Read) /* 206 */ #endif | | | 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 | #define Tcl_QueueEvent \ (tclStubsPtr->tcl_QueueEvent) /* 205 */ #endif #ifndef Tcl_Read #define Tcl_Read \ (tclStubsPtr->tcl_Read) /* 206 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef Tcl_ReapDetachedProcs #define Tcl_ReapDetachedProcs \ (tclStubsPtr->tcl_ReapDetachedProcs) /* 207 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef Tcl_ReapDetachedProcs |
| ︙ | ︙ |
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 | * * 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.9.14.3 2002/08/20 20:25:25 das Exp $ */ #include "tclInt.h" #include "tclPort.h" TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ */ |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | #endif /* * Declarations for local procedures defined in this file: */ static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, | | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | #endif /* * Declarations for local procedures defined in this file: */ static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); static void ReplaceString _ANSI_ARGS_((CONST char *oldStr, char *newStr)); void TclSetEnv _ANSI_ARGS_((CONST char *name, CONST char *value)); void TclUnsetEnv _ANSI_ARGS_((CONST char *name)); |
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
/* ARGSUSED */
static char *
EnvTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter whose "env" variable is
* being modified. */
| | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
/* ARGSUSED */
static char *
EnvTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter whose "env" variable is
* being modified. */
CONST char *name1; /* Better be "env". */
CONST char *name2; /* Name of variable being modified, or NULL
* if whole array is being deleted (UTF-8). */
int flags; /* Indicates what's happening. */
{
/*
* For array traces, let TclSetupEnv do all the work.
*/
|
| ︙ | ︙ |
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.15.2.3 2002/08/20 20:25:25 das Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The data structure below is used to report background errors. One |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 | * Prototypes for procedures referenced only in this file: */ static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, | | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | * Prototypes for procedures referenced only in this file: */ static void BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp)); static void HandleBgErrors _ANSI_ARGS_((ClientData clientData)); static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, CONST char *name1, CONST char *name2, int flags)); /* *---------------------------------------------------------------------- * * Tcl_BackgroundError -- * * This procedure is invoked to handle errors that occur in Tcl |
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
*/
static void
HandleBgErrors(clientData)
ClientData clientData; /* Pointer to ErrAssocData structure. */
{
Tcl_Interp *interp;
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
*/
static void
HandleBgErrors(clientData)
ClientData clientData; /* Pointer to ErrAssocData structure. */
{
Tcl_Interp *interp;
CONST char *argv[2];
int code;
BgError *errPtr;
ErrAssocData *assocPtr = (ErrAssocData *) clientData;
Tcl_Channel errChannel;
Tcl_Preserve((ClientData) assocPtr);
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 |
}
/* ARGSUSED */
static char *
VwaitVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
Tcl_Interp *interp; /* Interpreter containing variable. */
| | | 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 |
}
/* ARGSUSED */
static char *
VwaitVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *name1; /* Name of variable. */
CONST char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
{
int *donePtr = (int *) clientData;
*donePtr = 1;
return (char *) NULL;
|
| ︙ | ︙ |
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.34.4.3 2002/08/20 20:25:25 das Exp $ */ #include "tclInt.h" #include "tclCompile.h" #ifndef TCL_NO_MATH # include "tclMath.h" |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | * by comparing against the largest floating-point value. */ #define IS_NAN(v) ((v) != (v)) #define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) /* | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > | > | 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 |
* by comparing against the largest floating-point value.
*/
#define IS_NAN(v) ((v) != (v))
#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
/*
* The new macro for ending an instruction; note that a
* reasonable C-optimiser will resolve all branches
* at compile time. (result) is always a constant; the macro
* NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is
* resolved at runtime for variable (nCleanup).
*
* ARGUMENTS:
* pcAdjustment: how much to increment pc
* nCleanup: how many objects to remove from the stack
* result: 0 indicates no object should be pushed on the
* stack; otherwise, push objResultPtr. If (result < 0),
* objResultPtr already has the correct reference count.
*/
#define NEXT_INST_F(pcAdjustment, nCleanup, result) \
if (nCleanup == 0) {\
if (result != 0) {\
if ((result) > 0) {\
PUSH_OBJECT(objResultPtr);\
} else {\
stackPtr[++stackTop] = objResultPtr;\
}\
} \
pc += (pcAdjustment);\
goto cleanup0;\
} else if (result != 0) {\
if ((result) > 0) {\
Tcl_IncrRefCount(objResultPtr);\
}\
pc += (pcAdjustment);\
switch (nCleanup) {\
case 1: goto cleanup1_pushObjResultPtr;\
case 2: goto cleanup2_pushObjResultPtr;\
default: panic("ERROR: bad usage of macro NEXT_INST_F");\
}\
} else {\
pc += (pcAdjustment);\
switch (nCleanup) {\
case 1: goto cleanup1;\
case 2: goto cleanup2;\
default: panic("ERROR: bad usage of macro NEXT_INST_F");\
}\
}
#define NEXT_INST_V(pcAdjustment, nCleanup, result) \
pc += (pcAdjustment);\
cleanup = (nCleanup);\
if (result) {\
if ((result) > 0) {\
Tcl_IncrRefCount(objResultPtr);\
}\
goto cleanupV_pushObjResultPtr;\
} else {\
goto cleanupV;\
}
/*
* Macros used to cache often-referenced Tcl evaluation stack information
* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
* pair must surround any call inside TclExecuteByteCode (and a few other
* procedures that use this scheme) that could result in a recursive call
* to TclExecuteByteCode.
*/
#define CACHE_STACK_INFO() \
stackPtr = eePtr->stackPtr; \
stackTop = eePtr->stackTop
#define DECACHE_STACK_INFO() \
eePtr->stackTop = stackTop
/*
* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
* increments the object's ref count since it makes the stack have another
* reference pointing to the object. However, POP_OBJECT does not decrement
* the ref count. This is because the stack may hold the only reference to
* the object, so the object would be destroyed if its ref count were
|
| ︙ | ︙ | |||
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 |
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
if (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
(unsigned int)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
}
# define TRACE_WITH_OBJ(a, objPtr) \
if (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
(unsigned int)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
fprintf(stdout, "\n"); \
}
# define O2S(objPtr) \
(objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
# define TRACE(a)
# define TRACE_WITH_OBJ(a, objPtr)
# define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */
/*
* Most of the code to support working with wide values is factored
| > > > > > | 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 |
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a) \
if (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
(unsigned int)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
}
# define TRACE_APPEND(a) \
if (traceInstructions) { \
printf a; \
}
# define TRACE_WITH_OBJ(a, objPtr) \
if (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
(unsigned int)(pc - codePtr->codeStart), \
GetOpcodeName(pc)); \
printf a; \
TclPrintObject(stdout, objPtr, 30); \
fprintf(stdout, "\n"); \
}
# define O2S(objPtr) \
(objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
# define TRACE(a)
# define TRACE_APPEND(a)
# define TRACE_WITH_OBJ(a, objPtr)
# define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */
/*
* Most of the code to support working with wide values is factored
|
| ︙ | ︙ | |||
349 350 351 352 353 354 355 | /* * Table describing the built-in math functions. Entries in this table are * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's * operand byte. */ | | | 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 |
/*
* Table describing the built-in math functions. Entries in this table are
* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
* operand byte.
*/
BuiltinFunc tclBuiltinFuncTable[] = {
#ifndef TCL_NO_MATH
{"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
{"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
{"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
{"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
{"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
{"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 461 |
ExecEnv *
TclCreateExecEnv(interp)
Tcl_Interp *interp; /* Interpreter for which the execution
* environment is being created. */
{
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
| > | | > > > > > > > > > > | > > > > > > | 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 |
ExecEnv *
TclCreateExecEnv(interp)
Tcl_Interp *interp; /* Interpreter for which the execution
* environment is being created. */
{
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
Tcl_Obj **stackPtr;
stackPtr = (Tcl_Obj **)
ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
/*
* Use the bottom pointer to keep a reference count; the
* execution environment holds a reference.
*/
stackPtr++;
eePtr->stackPtr = stackPtr;
stackPtr[-1] = (Tcl_Obj *) ((char *) 1);
eePtr->stackTop = -1;
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2);
eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
Tcl_IncrRefCount(eePtr->errorInfo);
eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
Tcl_IncrRefCount(eePtr->errorCode);
Tcl_MutexLock(&execMutex);
if (!execInitialized) {
TclInitAuxDataTypeTable();
InitByteCodeExecution(interp);
execInitialized = 1;
}
|
| ︙ | ︙ | |||
493 494 495 496 497 498 499 |
*----------------------------------------------------------------------
*/
void
TclDeleteExecEnv(eePtr)
ExecEnv *eePtr; /* Execution environment to free. */
{
| > | > > > > > | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
*----------------------------------------------------------------------
*/
void
TclDeleteExecEnv(eePtr)
ExecEnv *eePtr; /* Execution environment to free. */
{
if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) {
ckfree((char *) (eePtr->stackPtr-1));
} else {
panic("ERROR: freeing an execEnv whose stack is still in use.\n");
}
TclDecrRefCount(eePtr->errorInfo);
TclDecrRefCount(eePtr->errorCode);
ckfree((char *) eePtr);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeExecution --
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 562 563 564 |
*/
int currElems = (eePtr->stackEnd + 1);
int newElems = 2*currElems;
int currBytes = currElems * sizeof(Tcl_Obj *);
int newBytes = 2*currBytes;
Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
/*
* Copy the existing stack items to the new stack space, free the old
| > > > > > > > > | > > | | > > > > > > > > > > > | > | 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 |
*/
int currElems = (eePtr->stackEnd + 1);
int newElems = 2*currElems;
int currBytes = currElems * sizeof(Tcl_Obj *);
int newBytes = 2*currBytes;
Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
Tcl_Obj **oldStackPtr = eePtr->stackPtr;
/*
* We keep the stack reference count as a (char *), as that
* works nicely as a portable pointer-sized counter.
*/
char *refCount = (char *) oldStackPtr[-1];
/*
* Copy the existing stack items to the new stack space, free the old
* storage if appropriate, and record the refCount of the new stack
* held by the environment.
*/
newStackPtr++;
memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr,
(size_t) currBytes);
if (refCount == (char *) 1) {
ckfree((VOID *) (oldStackPtr-1));
} else {
/*
* Remove the reference corresponding to the
* environment pointer.
*/
oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
}
eePtr->stackPtr = newStackPtr;
eePtr->stackEnd = (newElems - 2); /* index of last usable item */
newStackPtr[-1] = (Tcl_Obj *) ((char *) 1);
}
/*
*--------------------------------------------------------------
*
* Tcl_ExprObj --
*
|
| ︙ | ︙ | |||
822 823 824 825 826 827 828 |
* Check that the interpreter is ready to execute scripts
*/
if (TclInterpReady(interp) == TCL_ERROR) {
return TCL_ERROR;
}
| < < < < < < < < < < < < < < < < < < < < > > > > > > > | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > < < < < < < < < < < < < | < < < < < < < < < < < < < | 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 |
* 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;
}
iPtr->evalFlags = 0;
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
* different interpreter, or for a different namespace, or for the
* same namespace but with different name resolution rules.
* Precompiled objects, however, are immutable and therefore
* they are not recompiled, even if the epoch has changed.
*
* To be pedantically correct, we should also check that the
* originating procPtr is the same as the current context procPtr
* (assuming one exists at all - none for global level). This
* code is #def'ed out because [info body] was changed to never
* return a bytecode type object, which should obviate us from
* the extra checks here.
*/
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
|| (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
iPtr->varFramePtr->procPtr == codePtr->procPtr))
#endif
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
panic("Tcl_EvalObj: compiled script jumped interps");
}
codePtr->compileEpoch = iPtr->compileEpoch;
} else {
/*
* This byteCode is invalid: free it and recompile
*/
tclByteCodeType.freeIntRepProc(objPtr);
goto recompileObj;
}
}
}
/*
* Execute the commands. If the code was compiled from an empty string,
* don't bother executing the code.
*/
numSrcBytes = codePtr->numSrcBytes;
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 |
/* Points to the execution environment. */
register Tcl_Obj **stackPtr = eePtr->stackPtr;
/* Cached evaluation stack base pointer. */
register int stackTop = eePtr->stackTop;
/* Cached top index of evaluation stack. */
register unsigned char *pc = codePtr->codeStart;
/* The current program counter. */
| | < | < | > > > > > > > > > > | 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 |
/* Points to the execution environment. */
register Tcl_Obj **stackPtr = eePtr->stackPtr;
/* Cached evaluation stack base pointer. */
register int stackTop = eePtr->stackTop;
/* Cached top index of evaluation stack. */
register unsigned char *pc = codePtr->codeStart;
/* The current program counter. */
int opnd; /* Current instruction's operand byte(s). */
int pcAdjustment; /* Hold pc adjustment after instruction. */
int initStackTop = stackTop;/* Stack top at start of execution. */
ExceptionRange *rangePtr; /* Points to closest loop or catch exception
* range enclosing the pc. Used by various
* instructions and processCatch to
* 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. */
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w;
#endif
register int cleanup;
Tcl_Obj *objResultPtr;
char *part1, *part2;
Var *varPtr, *arrayPtr;
CallFrame *varFramePtr = iPtr->varFramePtr;
#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_COMPILE_DEBUG
if (tclTraceExec >= 2) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
fflush(stdout);
}
opnd = 0; /* Init. avoids compiler warning. */
#endif
#ifdef TCL_COMPILE_STATS
iPtr->stats.numExecutions++;
#endif
/*
|
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 |
while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
GrowEvaluationStack(eePtr);
stackPtr = eePtr->stackPtr;
}
/*
| | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | > | | | | | | | | | | | > | | < | | | | | | < | < | < < < | | | < | | | > | < | | | | | < | | | | | < | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < < < | | < < < | | | | | | | | | | | | | | | > > > > > | > > | | | > | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | > > > > > | | > | | | | | | | | | | | | | | | | | | | | | | | | < < < < | < < < | < < < < < | | | | | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > | < < < < < < | < < < < | < < | < < < | < < < < < < < < | | < > > | < | < < < < < < < < < < < < | | | | | | | | > | | | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < | < < < < < < | < < < < | < < | < < < < < < < < | < | | | | | | | | | < | | | | > | < > > > | > > > > > | | < > > > | > | > | < > > > | > > > | > > > | | > > > > > | > | < > > > > > > > > | > > > > > > | | < | < | | < < | | < < | > > > > > | | | < | > | | < | < | | | > | > > > | > | > | > > > | | | | | | | | | > > > > | | < > | | < | < | < | | | > | < > > > | > | > | | > > | | > > > > | | | | | | < < | < < | | | < | > | > > > > | > > > > > > > > | | > > > > > | > | < > > | > > > > > > | > | < > > | | < | | > | > > > | < < < | < | > > | > > | | > > | < | < < < < < > | | < > > | < < | < < | | | > > > | > > > > | > | > > > > > > | > > > > > | | > > > > | | | > | | | | > | | > | < < < < | | | < | | < < | < < < < < < | < < < < < < | < | < < | < < < | | | > | < < < < < < < < < < < | | | > > | | | | < < < < < | < < < < < | < < < < < < < | < < < < < < < | < | < | > | < | < < < < < < < < < | > | < | > | | < < < < < < < < < < < < < < | | | > | | | | > | | | < < < < | < | < | | < < | < < < < < < | < < < | < < < < < | < < < < < | | < < | < < < | < < < < | < < < | | | < < < < | < < < < < < < < < < < | < < < < < > > > < < | < < < < < < < | < < < < < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < > > > | > > | > | > > > | > | > > > > > > > > | | < < > > | > | | < < < < < | | | < < < < < < < | < < < < < < > > > > | > | > > > > | | > > > > | | | | | | | | | | | < | | | | < < < < < < < < | < < < | < | | > > | | < < < < < < < < < > | | < < < < | | < | < < < < < < < < < < < < < < < < < | | | | | | | | | | | | > | < | > | < < < < < | | | < | | < | < < > > | > > > > > | > | > | < | < | > | > | | < | < | | | < < | | < < < < < < < | < < < > | | < < < < < < < < < < < < < | | | < < < < < < < < | | | > | > > > > > > > > > > < < < < < < < | < < < < < > | | < > | < < | < < < | < < < | > > | < > < < < < < < < < < | < | | | | < > | < < | | < | < | | < | | | < < | < < < < > | < < > | > | > > > | | > | > | < | | | | < < < < | | | | > | > > > > | | | | > > > > > | | | | | | | | | | | | | | | | | < < | | | > > > | > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | > | | | < < > | < | < > | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | < < | | | | | | | | | | | | | | | | | | | | | | | < | | | < | | < < | | | | | | | | | | | | | | | | < | | < | < > | > | > > > > | > > > > > | > > > > | | | | | | < | | | | < | | | | | | | | | | | | | | < | < < | | | | | | < | | | < < < | | | | | | | | | | | | | | | | < < < < < < < < < < < < | | | | < | | | | | | < | < > | < | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < < < < | | | | | < | | | | | | < | < > | < | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | < | > | > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | > | > > | > > > > > > > > > > > | > > | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | < | | | | | | | | | | | < > | < | | | | | | | | | | | | | | | | | | | | | | | | < | < < | | | | | | | | | | | | | | | | | | | | | | < | | < < > | < | | | | | | | | | | | | | | | | | | | | > | | < < | | < > | | < > | | < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < | | | > > | > | | > > | | < > > > > > > | < > > > | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | < < | | | | | | | | < < | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | < | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | < | > | < > | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | < | > | | | | | | | | | | | | < | > | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | > | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | < | < | | | | | > | | | | | | | | | | < < | < < | | | | | | | | | | | | | | < | | | < > | | | < < | | < < < < < < < | < | < < < < | < < < < < < < < < < < < | < < | | < < < < < < < < | < < < | > | | < | < < < | | < < < | < < < | < < < < < | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > | | | | > | | | | | > > | | < < > > > | > > | < < > | < > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | > > > > | | < > | > > > > > > > | | | | | | | < < | < > > | < < | | < < | | < < < > | < < < < | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > | > | | | 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 |
while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
GrowEvaluationStack(eePtr);
stackPtr = eePtr->stackPtr;
}
/*
* Loop executing instructions until a "done" instruction, a
* TCL_RETURN, or some error.
*/
goto cleanup0;
/*
* Targets for standard instruction endings; unrolled
* for speed in the most frequent cases (instructions that
* consume up to two stack elements).
*
* This used to be a "for(;;)" loop, with each instruction doing
* its own cleanup.
*/
cleanupV_pushObjResultPtr:
switch (cleanup) {
case 0:
stackPtr[++stackTop] = (objResultPtr);
goto cleanup0;
default:
cleanup -= 2;
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
case 2:
cleanup2_pushObjResultPtr:
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
case 1:
cleanup1_pushObjResultPtr:
valuePtr = stackPtr[stackTop];
TclDecrRefCount(valuePtr);
}
stackPtr[stackTop] = objResultPtr;
goto cleanup0;
cleanupV:
switch (cleanup) {
default:
cleanup -= 2;
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
case 2:
cleanup2:
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
case 1:
cleanup1:
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
case 0:
/*
* We really want to do nothing now, but this is needed
* for some compilers (SunPro CC)
*/
break;
}
cleanup0:
#ifdef TCL_COMPILE_DEBUG
ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
if (traceInstructions) {
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
TclPrintInstruction(codePtr, pc);
fflush(stdout);
}
#endif /* TCL_COMPILE_DEBUG */
#ifdef TCL_COMPILE_STATS
iPtr->stats.instructionCount[*pc]++;
#endif
switch (*pc) {
case INST_DONE:
if (stackTop <= initStackTop) {
stackTop--;
goto abnormalReturn;
}
/*
* Set the interpreter's object result to point to the
* topmost object from the stack, and check for a possible
* [catch]. The stackTop's level and refCount will be handled
* by "processCatch" or "abnormalReturn".
*/
valuePtr = stackPtr[stackTop];
Tcl_SetObjResult(interp, valuePtr);
#ifdef TCL_COMPILE_DEBUG
TRACE_WITH_OBJ(("=> return code=%d, result=", result),
iPtr->objResultPtr);
if (traceInstructions) {
fprintf(stdout, "\n");
}
#endif
goto checkForCatch;
case INST_PUSH1:
objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(2, 0, 1);
case INST_PUSH4:
objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(5, 0, 1);
case INST_POP:
TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]);
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
NEXT_INST_F(1, 0, 0);
case INST_DUP:
objResultPtr = stackPtr[stackTop];
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_OVER:
opnd = TclGetUInt4AtPtr( pc+1 );
objResultPtr = stackPtr[ stackTop - opnd ];
TRACE_WITH_OBJ(("=> "), objResultPtr);
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++) {
bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
if (bytes != NULL) {
totalLen += length;
}
}
/*
* Initialize the new append string object by appending the
* strings of the opnd stack objects. Also pop the objects.
*/
TclNewObj(objResultPtr);
if (totalLen > 0) {
char *p = (char *) ckalloc((unsigned) (totalLen + 1));
objResultPtr->bytes = p;
objResultPtr->length = totalLen;
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
valuePtr = stackPtr[i];
bytes = Tcl_GetStringFromObj(valuePtr, &length);
if (bytes != NULL) {
memcpy((VOID *) p, (VOID *) bytes,
(size_t) length);
p += length;
}
}
*p = '\0';
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
}
case INST_INVOKE_STK4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doInvocation;
case INST_INVOKE_STK1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doInvocation:
{
int objc = opnd; /* The number of arguments. */
Tcl_Obj **objv; /* The array of argument objects. */
/*
* We keep the stack reference count as a (char *), as that
* works nicely as a portable pointer-sized counter.
*/
char **preservedStackRefCountPtr;
/*
* Reference to memory block containing
* objv array (must be kept live throughout
* trace and command invokations.)
*/
objv = &(stackPtr[stackTop - (objc-1)]);
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
TRACE(("%u => call ", objc));
} else {
fprintf(stdout, "%d: (%u) invoking ",
iPtr->numLevels,
(unsigned int)(pc - codePtr->codeStart));
}
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
/*
* If trace procedures will be called, we need a
* command string to pass to TclEvalObjvInternal; note
* that a copy of the string will be made there to
* include the ending \0.
*/
bytes = NULL;
length = 0;
if (iPtr->tracePtr != NULL) {
Trace *tracePtr, *nextTracePtr;
for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
tracePtr = nextTracePtr) {
nextTracePtr = tracePtr->nextPtr;
if (tracePtr->level == 0 ||
iPtr->numLevels <= tracePtr->level) {
/*
* Traces will be called: get command string
*/
bytes = GetSrcInfoForPc(pc, codePtr, &length);
break;
}
}
} else {
Command *cmdPtr;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
}
}
/*
* A reference to part of the stack vector itself
* escapes our control: increase its refCount
* to stop it from being deallocated by a recursive
* call to ourselves. The extra variable is needed
* because all others are liable to change due to the
* trace procedures.
*/
preservedStackRefCountPtr = (char **) (stackPtr-1);
++*preservedStackRefCountPtr;
/*
* Finally, let TclEvalObjvInternal handle the command.
*/
Tcl_ResetResult(interp);
DECACHE_STACK_INFO();
result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
CACHE_STACK_INFO();
/*
* 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.
*/
--*preservedStackRefCountPtr;
if (*preservedStackRefCountPtr == (char *) 0) {
ckfree((VOID *) preservedStackRefCountPtr);
}
if (result == TCL_OK) {
/*
* Push the call's object result and continue execution
* with the next instruction.
*/
TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
objResultPtr = Tcl_GetObjResult(interp);
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();
result = TclCompEvalObj(interp, objPtr);
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));
NEXT_INST_F(1, 1, 1);
} else {
cleanup = 1;
goto processExceptionReturn;
}
case INST_EXPR_STK:
objPtr = stackPtr[stackTop];
Tcl_ResetResult(interp);
DECACHE_STACK_INFO();
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;
}
objResultPtr = valuePtr;
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
NEXT_INST_F(1, 1, -1); /* already has right refct */
/*
* ---------------------------------------------------------
* Start of INST_LOAD instructions.
*
* WARNING: more 'goto' here than your doctor recommended!
* The different instructions set the value of some variables
* and then jump to somme common execution code.
*/
case INST_LOAD_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(2, 0, 1);
}
pcAdjustment = 2;
cleanup = 0;
arrayPtr = NULL;
part2 = NULL;
goto doCallPtrGetVar;
case INST_LOAD_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 0, 1);
}
pcAdjustment = 5;
cleanup = 0;
arrayPtr = NULL;
part2 = NULL;
goto doCallPtrGetVar;
case INST_LOAD_ARRAY_STK:
cleanup = 2;
part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */
objPtr = stackPtr[stackTop-1]; /* array name */
TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));
goto doLoadStk;
case INST_LOAD_STK:
case INST_LOAD_SCALAR_STK:
cleanup = 1;
part2 = NULL;
objPtr = stackPtr[stackTop]; /* variable name */
TRACE(("\"%.30s\" => ", O2S(objPtr)));
doLoadStk:
part1 = TclGetString(objPtr);
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "read",
/*createPart1*/ 0,
/*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(1, cleanup, 1);
}
pcAdjustment = 1;
goto doCallPtrGetVar;
case INST_LOAD_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doLoadArray;
case INST_LOAD_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadArray:
part2 = TclGetString(stackPtr[stackTop]);
arrayPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = arrayPtr->name;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" => ", opnd, part2));
varPtr = TclLookupArrayElement(interp, part1, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
}
cleanup = 1;
goto doCallPtrGetVar;
doCallPtrGetVar:
/*
* There are either errors or the variable is traced:
* call TclPtrGetVar to process fully.
*/
DECACHE_STACK_INFO();
objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1,
part2, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_LOAD instructions.
* ---------------------------------------------------------
*/
/*
* ---------------------------------------------------------
* Start of INST_STORE and related instructions.
*
* WARNING: more 'goto' here than your doctor recommended!
* The different instructions set the value of some variables
* and then jump to somme common execution code.
*/
case INST_LAPPEND_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreStk;
case INST_LAPPEND_ARRAY_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = TclGetString(stackPtr[stackTop - 1]);
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreStk;
case INST_APPEND_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreStk;
case INST_APPEND_ARRAY_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = TclGetString(stackPtr[stackTop - 1]);
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreStk;
case INST_STORE_ARRAY_STK:
valuePtr = stackPtr[stackTop];
part2 = TclGetString(stackPtr[stackTop - 1]);
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreStk;
case INST_STORE_STK:
case INST_STORE_SCALAR_STK:
valuePtr = stackPtr[stackTop];
part2 = NULL;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreStk:
objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */
part1 = TclGetString(objPtr);
#ifdef TCL_COMPILE_DEBUG
if (part2 == NULL) {
TRACE(("\"%.30s\" <- \"%.30s\" =>",
part1, O2S(valuePtr)));
} else {
TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
part1, part2, O2S(valuePtr)));
}
#endif
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "set",
/*createPart1*/ 1,
/*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = ((part2 == NULL)? 2 : 3);
pcAdjustment = 1;
goto doCallPtrSetVar;
case INST_LAPPEND_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreArray;
case INST_LAPPEND_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreArray;
case INST_APPEND_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreArray;
case INST_APPEND_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreArray;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreArray;
case INST_STORE_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreArray:
valuePtr = stackPtr[stackTop];
part2 = TclGetString(stackPtr[stackTop - 1]);
arrayPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = arrayPtr->name;
TRACE(("%u \"%.30s\" <- \"%.30s\" => ",
opnd, part2, O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
varPtr = TclLookupArrayElement(interp, part1, part2,
TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = 2;
goto doCallPtrSetVar;
case INST_LAPPEND_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreScalar;
case INST_LAPPEND_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreScalar;
case INST_APPEND_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreScalar;
case INST_APPEND_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreScalar;
case INST_STORE_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreScalar;
case INST_STORE_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreScalar:
valuePtr = stackPtr[stackTop];
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
cleanup = 1;
arrayPtr = NULL;
part2 = NULL;
doCallPtrSetVar:
if ((storeFlags == TCL_LEAVE_ERR_MSG)
&& !((varPtr->flags & VAR_IN_HASHTABLE)
&& (varPtr->hPtr == NULL))
&& (varPtr->tracePtr == NULL)
&& (TclIsVarScalar(varPtr)
|| TclIsVarUndefined(varPtr))
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))) {
/*
* No traces, no errors, plain 'set': we can safely inline.
* The value *will* be set to what's requested, so that
* the stack top remains pointing to the same Tcl_Obj.
*/
valuePtr = varPtr->value.objPtr;
objResultPtr = stackPtr[stackTop];
if (valuePtr != objResultPtr) {
if (valuePtr != NULL) {
TclDecrRefCount(valuePtr);
} else {
TclSetVarScalar(varPtr);
TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = objResultPtr;
Tcl_IncrRefCount(objResultPtr);
}
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#else
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#endif
NEXT_INST_V(pcAdjustment, cleanup, 1);
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
part1, part2, valuePtr, storeFlags);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
}
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_STORE and related instructions.
* ---------------------------------------------------------
*/
/*
* ---------------------------------------------------------
* Start of INST_INCR instructions.
*
* WARNING: more 'goto' here than your doctor recommended!
* The different instructions set the value of some variables
* and then jump to somme common execution code.
*/
case INST_INCR_SCALAR1:
case INST_INCR_ARRAY1:
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;
#ifndef TCL_WIDE_INT_IS_LONG
} else if (valuePtr->typePtr == &tclWideIntType) {
i = Tcl_WideAsLong(valuePtr->internalRep.wideValue);
#endif /* TCL_WIDE_INT_IS_LONG */
} 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));
goto checkForCatch;
}
FORCE_LONG(valuePtr, i, w);
}
stackTop--;
TclDecrRefCount(valuePtr);
switch (*pc) {
case INST_INCR_SCALAR1:
pcAdjustment = 2;
goto doIncrScalar;
case INST_INCR_ARRAY1:
pcAdjustment = 2;
goto doIncrArray;
default:
pcAdjustment = 1;
goto doIncrStk;
}
case INST_INCR_ARRAY_STK_IMM:
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
i = TclGetInt1AtPtr(pc+1);
pcAdjustment = 2;
doIncrStk:
if ((*pc == INST_INCR_ARRAY_STK_IMM)
|| (*pc == INST_INCR_ARRAY_STK)) {
part2 = TclGetString(stackPtr[stackTop]);
objPtr = stackPtr[stackTop - 1];
TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
O2S(objPtr), part2, i));
} else {
part2 = NULL;
objPtr = stackPtr[stackTop];
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;
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
pcAdjustment = 3;
doIncrArray:
part2 = TclGetString(stackPtr[stackTop]);
arrayPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = arrayPtr->name;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u \"%.30s\" (by %ld) => ",
opnd, part2, i));
varPtr = TclLookupArrayElement(interp, part1, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = 1;
goto doIncrVar;
case INST_INCR_SCALAR1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
pcAdjustment = 3;
doIncrScalar:
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part2 = NULL;
cleanup = 0;
TRACE(("%u %ld => ", opnd, i));
doIncrVar:
objPtr = varPtr->value.objPtr;
if (TclIsVarScalar(varPtr)
&& !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))
&& (objPtr->typePtr == &tclIntType)) {
/*
* No errors, no traces, the variable already has an
* integer value: inline processing.
*/
i += objPtr->internalRep.longValue;
if (Tcl_IsShared(objPtr)) {
objResultPtr = Tcl_NewLongObj(i);
TclDecrRefCount(objPtr);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
Tcl_SetLongObj(objPtr, i);
objResultPtr = objPtr;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1,
part2, i, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_INCR instructions.
* ---------------------------------------------------------
*/
case INST_JUMP1:
opnd = TclGetInt1AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
case INST_JUMP4:
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
case INST_JUMP_FALSE4:
opnd = 5; /* TRUE */
pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */
goto doJumpTrue;
case INST_JUMP_TRUE4:
opnd = TclGetInt4AtPtr(pc+1); /* TRUE */
pcAdjustment = 5; /* FALSE */
goto doJumpTrue;
case INST_JUMP_FALSE1:
opnd = 2; /* TRUE */
pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */
goto doJumpTrue;
case INST_JUMP_TRUE1:
opnd = TclGetInt1AtPtr(pc+1); /* TRUE */
pcAdjustment = 2; /* FALSE */
doJumpTrue:
{
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);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (valuePtr->typePtr == &tclWideIntType) {
b = (valuePtr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
goto checkForCatch;
}
}
#ifndef TCL_COMPILE_DEBUG
NEXT_INST_F((b? opnd : pcAdjustment), 1, 0);
#else
if (b) {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr),
(unsigned int)(pc+opnd - codePtr->codeStart)));
} else {
TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr)));
}
NEXT_INST_F(opnd, 1, 0);
} else {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
} else {
opnd = pcAdjustment;
TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr),
(unsigned int)(pc + opnd - codePtr->codeStart)));
}
NEXT_INST_F(pcAdjustment, 1, 0);
}
#endif
}
case INST_LOR:
case INST_LAND:
{
/*
* Operands must be boolean or numeric. No int->double
* conversions are performed.
*/
int i1, i2;
int iResult;
char *s;
Tcl_ObjType *t1Ptr, *t2Ptr;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];;
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
i1 = (valuePtr->internalRep.longValue != 0);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (t1Ptr == &tclWideIntType) {
i1 = (valuePtr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
} else if (t1Ptr == &tclDoubleType) {
i1 = (valuePtr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
#ifdef TCL_WIDE_INT_IS_LONG
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
i1 = (i != 0);
#else /* !TCL_WIDE_INT_IS_LONG */
GET_WIDE_OR_INT(result, valuePtr, i, w);
if (valuePtr->typePtr == &tclIntType) {
i1 = (i != 0);
} else {
i1 = (w != W0);
}
#endif /* TCL_WIDE_INT_IS_LONG */
} 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")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
}
if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
i2 = (value2Ptr->internalRep.longValue != 0);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (t2Ptr == &tclWideIntType) {
i2 = (value2Ptr->internalRep.wideValue != W0);
#endif /* TCL_WIDE_INT_IS_LONG */
} else if (t2Ptr == &tclDoubleType) {
i2 = (value2Ptr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s, length)) {
#ifdef TCL_WIDE_INT_IS_LONG
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i);
i2 = (i != 0);
#else /* !TCL_WIDE_INT_IS_LONG */
GET_WIDE_OR_INT(result, value2Ptr, i, w);
if (value2Ptr->typePtr == &tclIntType) {
i2 = (i != 0);
} else {
i2 = (w != W0);
}
#endif /* TCL_WIDE_INT_IS_LONG */
} 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")));
IllegalExprOperandType(interp, pc, value2Ptr);
goto checkForCatch;
}
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (*pc == INST_LOR) {
iResult = (i1 || i2);
} else {
iResult = (i1 && i2);
}
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
Tcl_SetLongObj(valuePtr, iResult);
NEXT_INST_F(1, 1, 0);
}
}
/*
* ---------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
case INST_LIST:
/*
* Pop the opnd (objc) top stack elements into a new list obj
* and then decrement their ref counts.
*/
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)]));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
case INST_LIST_LENGTH:
valuePtr = stackPtr[stackTop];
result = Tcl_ListObjLength(interp, valuePtr, &length);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
Tcl_GetObjResult(interp));
goto checkForCatch;
}
objResultPtr = Tcl_NewIntObj(length);
TRACE(("%.20s => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX:
/*** lindex with objc == 3 ***/
/*
* Pop the two operands
*/
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop- 1];
/*
* Extract the desired list element
*/
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Stash the list element on the stack
*/
TRACE(("%.20s %.20s => %s\n",
O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1); /* already has the correct refCount */
case INST_LIST_INDEX_MULTI:
{
/*
* 'lindex' with multiple index args:
*
* Determine the count of index args.
*/
int numIdx;
opnd = TclGetUInt4AtPtr(pc+1);
numIdx = opnd-1;
/*
* Do the 'lindex' operation.
*/
objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx],
numIdx, stackPtr + stackTop - numIdx + 1);
/*
* Check for errors
*/
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Set result
*/
TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, opnd, -1);
}
case INST_LSET_FLAT:
{
/*
* Lset with 3, 5, or more args. Get the number
* of index args.
*/
int numIdx;
opnd = TclGetUInt4AtPtr( pc + 1 );
numIdx = opnd - 2;
/*
* Get the old value of variable, and remove the stack ref.
* This is safe because the variable still references the
* object; the ref count will never go zero here.
*/
value2Ptr = POP_OBJECT();
TclDecrRefCount(value2Ptr); /* This one should be done here */
/*
* Get the new element value.
*/
valuePtr = stackPtr[stackTop];
/*
* Compute the new variable value
*/
objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
stackPtr + stackTop - numIdx, valuePtr);
/*
* Check for errors
*/
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Set result
*/
TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, (numIdx+1), -1);
}
case INST_LSET_LIST:
/*
* 'lset' with 4 args.
*
* Get the old value of variable, and remove the stack ref.
* This is safe because the variable still references the
* object; the ref count will never go zero here.
*/
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr); /* This one should be done here */
/*
* Get the new element value, and the index list
*/
valuePtr = stackPtr[stackTop];
value2Ptr = stackPtr[stackTop - 1];
/*
* Compute the new variable value
*/
objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
/*
* Check for errors
*/
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Set result
*/
TRACE(("=> %s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1);
/*
* End of INST_LIST and related instructions.
* ---------------------------------------------------------
*/
case INST_STR_EQ:
case INST_STR_NEQ:
{
/*
* String (in)equality check
*/
int iResult;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
if (valuePtr == value2Ptr) {
/*
* On the off-chance that the objects are the same,
* we don't really have to think hard about equality.
*/
iResult = (*pc == INST_STR_EQ);
} else {
char *s1, *s2;
int s1len, s2len;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
if (s1len == s2len) {
/*
* We only need to check (in)equality when
* we have equal length strings.
*/
if (*pc == INST_STR_NEQ) {
iResult = (strcmp(s1, s2) != 0);
} else {
/* INST_STR_EQ */
iResult = (strcmp(s1, s2) == 0);
}
} else {
iResult = (*pc == INST_STR_NEQ);
}
}
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
/*
* Peep-hole optimisation: if you're about to jump, do jump
* from here.
*/
pc++;
#ifndef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_JUMP_FALSE1:
NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE1:
NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
case INST_JUMP_FALSE4:
NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE4:
NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
objResultPtr = Tcl_NewIntObj(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_STR_CMP:
{
/*
* String compare
*/
CONST char *s1, *s2;
int s1len, s2len, iResult;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
/*
* The comparison function should compare up to the
* minimum byte length only.
*/
if (valuePtr == value2Ptr) {
/*
* In the pure equality case, set lengths too for
* the checks below (or we could goto beyond it).
*/
iResult = s1len = s2len = 0;
} else if ((valuePtr->typePtr == &tclByteArrayType)
&& (value2Ptr->typePtr == &tclByteArrayType)) {
s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
iResult = memcmp(s1, s2,
(size_t) ((s1len < s2len) ? s1len : s2len));
} else if (((valuePtr->typePtr == &tclStringType)
&& (value2Ptr->typePtr == &tclStringType))) {
/*
* Do a unicode-specific comparison if both of the args
* are of String type. In benchmark testing this proved
* the most efficient check between the unicode and
* string comparison operations.
*/
Tcl_UniChar *uni1, *uni2;
uni1 = Tcl_GetUnicodeFromObj(valuePtr, &s1len);
uni2 = Tcl_GetUnicodeFromObj(value2Ptr, &s2len);
iResult = TclUniCharNcmp(uni1, uni2,
(unsigned) ((s1len < s2len) ? s1len : s2len));
} else {
/*
* We can't do a simple memcmp in order to handle the
* special Tcl \xC0\x80 null encoding for utf-8.
*/
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
iResult = TclpUtfNcmp2(s1, s2,
(size_t) ((s1len < s2len) ? s1len : s2len));
}
/*
* Make sure only -1,0,1 is returned
*/
if (iResult == 0) {
iResult = s1len - s2len;
}
if (iResult < 0) {
iResult = -1;
} else if (iResult > 0) {
iResult = 1;
}
objResultPtr = Tcl_NewIntObj(iResult);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
NEXT_INST_F(1, 2, 1);
}
case INST_STR_LEN:
{
int length1;
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclByteArrayType) {
(void) Tcl_GetByteArrayFromObj(valuePtr, &length1);
} else {
length1 = Tcl_GetCharLength(valuePtr);
}
objResultPtr = Tcl_NewIntObj(length1);
TRACE(("%.20s => %d\n", O2S(valuePtr), length1));
NEXT_INST_F(1, 1, 1);
}
case INST_STR_INDEX:
{
/*
* String compare
*/
int index;
bytes = NULL; /* lint */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
/*
* If we have a ByteArray object, avoid indexing in the
* Utf string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* get the index'th char.
*/
if (valuePtr->typePtr == &tclByteArrayType) {
bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
} else {
/*
* Get Unicode char length to calulate what 'end' means.
*/
length = Tcl_GetCharLength(valuePtr);
}
result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
if (result != TCL_OK) {
goto checkForCatch;
}
if ((index >= 0) && (index < length)) {
if (valuePtr->typePtr == &tclByteArrayType) {
objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
(&bytes[index]), 1);
} else {
char buf[TCL_UTF_MAX];
Tcl_UniChar ch;
ch = Tcl_GetUniChar(valuePtr, index);
/*
* This could be:
* Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
* but creating the object as a string seems to be
* faster in practical use.
*/
length = Tcl_UniCharToUtf(ch, buf);
objResultPtr = Tcl_NewStringObj(buf, length);
}
} else {
TclNewObj(objResultPtr);
}
TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
case INST_STR_MATCH:
{
int nocase, match;
nocase = TclGetInt1AtPtr(pc+1);
valuePtr = stackPtr[stackTop]; /* String */
value2Ptr = stackPtr[stackTop - 1]; /* Pattern */
/*
* Check that at least one of the objects is Unicode before
* promoting both.
*/
if ((valuePtr->typePtr == &tclStringType)
|| (value2Ptr->typePtr == &tclStringType)) {
match = Tcl_UniCharCaseMatch(Tcl_GetUnicode(valuePtr),
Tcl_GetUnicode(value2Ptr), nocase);
} else {
match = Tcl_StringCaseMatch(TclGetString(valuePtr),
TclGetString(value2Ptr), nocase);
}
/*
* Reuse value2Ptr object already on stack if possible.
* Adjustment is 2 due to the nocase byte
*/
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
if (Tcl_IsShared(value2Ptr)) {
objResultPtr = Tcl_NewIntObj(match);
NEXT_INST_F(2, 2, 1);
} else { /* reuse the valuePtr object */
Tcl_SetIntObj(value2Ptr, match);
NEXT_INST_F(2, 1, 0);
}
}
case INST_EQ:
case INST_NEQ:
case INST_LT:
case INST_GT:
case INST_LE:
case INST_GE:
{
/*
* Any type is allowed but the two operands must have the
* same type. We will compute value op value2.
*/
Tcl_ObjType *t1Ptr, *t2Ptr;
char *s1 = NULL; /* Init. avoids compiler warning. */
char *s2 = NULL; /* Init. avoids compiler warning. */
long i2 = 0; /* Init. avoids compiler warning. */
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) {
/*
* Optimize the equal object case.
*/
switch (*pc) {
case INST_EQ:
case INST_LE:
case INST_GE:
iResult = 1;
break;
case INST_NEQ:
case INST_LT:
case INST_GT:
iResult = 0;
break;
}
goto foundResult;
}
t1Ptr = valuePtr->typePtr;
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]).
*/
if (!( (!t1Ptr && !valuePtr->bytes)
|| (valuePtr->bytes && !valuePtr->length)
|| (!t2Ptr && !value2Ptr->bytes)
|| (value2Ptr->bytes && !value2Ptr->length))) {
if (!IS_NUMERIC_TYPE(t1Ptr)) {
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;
}
if (!IS_NUMERIC_TYPE(t2Ptr)) {
s2 = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s2, length)) {
GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
value2Ptr, &d2);
}
t2Ptr = value2Ptr->typePtr;
}
}
if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
/*
* One operand is not numeric. Compare as strings. NOTE:
* strcmp is not correct for \x00 < \x01, but that is
* unlikely to occur here. We could use the TclUtfNCmp2
* to handle this.
*/
int s1len, s2len;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
switch (*pc) {
case INST_EQ:
if (s1len == s2len) {
iResult = (strcmp(s1, s2) == 0);
} else {
iResult = 0;
}
break;
case INST_NEQ:
if (s1len == s2len) {
iResult = (strcmp(s1, s2) != 0);
} else {
iResult = 1;
}
break;
case INST_LT:
iResult = (strcmp(s1, s2) < 0);
break;
case INST_GT:
iResult = (strcmp(s1, s2) > 0);
break;
case INST_LE:
iResult = (strcmp(s1, s2) <= 0);
break;
case INST_GE:
iResult = (strcmp(s1, s2) >= 0);
break;
}
} else if ((t1Ptr == &tclDoubleType)
|| (t2Ptr == &tclDoubleType)) {
/*
* Compare as doubles.
*/
if (t1Ptr == &tclDoubleType) {
d1 = valuePtr->internalRep.doubleValue;
GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
} else { /* t1Ptr is integer, t2Ptr is double */
GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
d2 = value2Ptr->internalRep.doubleValue;
}
switch (*pc) {
case INST_EQ:
iResult = d1 == d2;
break;
case INST_NEQ:
iResult = d1 != d2;
break;
case INST_LT:
iResult = d1 < d2;
break;
case INST_GT:
iResult = d1 > d2;
break;
case INST_LE:
iResult = d1 <= d2;
break;
case INST_GE:
iResult = d1 >= d2;
break;
}
#ifndef TCL_WIDE_INT_IS_LONG
} 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);
w2 = value2Ptr->internalRep.wideValue;
} else if (t2Ptr == &tclIntType) {
w = valuePtr->internalRep.wideValue;
w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
} else {
w = valuePtr->internalRep.wideValue;
w2 = value2Ptr->internalRep.wideValue;
}
switch (*pc) {
case INST_EQ:
iResult = w == w2;
break;
case INST_NEQ:
iResult = w != w2;
break;
case INST_LT:
iResult = w < w2;
break;
case INST_GT:
iResult = w > w2;
break;
case INST_LE:
iResult = w <= w2;
break;
case INST_GE:
iResult = w >= w2;
break;
}
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
/*
* Compare as ints.
*/
i = valuePtr->internalRep.longValue;
i2 = value2Ptr->internalRep.longValue;
switch (*pc) {
case INST_EQ:
iResult = i == i2;
break;
case INST_NEQ:
iResult = i != i2;
break;
case INST_LT:
iResult = i < i2;
break;
case INST_GT:
iResult = i > i2;
break;
case INST_LE:
iResult = i <= i2;
break;
case INST_GE:
iResult = i >= i2;
break;
}
}
foundResult:
TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult));
/*
* Peep-hole optimisation: if you're about to jump, do jump
* from here.
*/
pc++;
#ifndef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_JUMP_FALSE1:
NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE1:
NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
case INST_JUMP_FALSE4:
NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
case INST_JUMP_TRUE4:
NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
}
#endif
objResultPtr = Tcl_NewIntObj(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_MOD:
case INST_LSHIFT:
case INST_RSHIFT:
case INST_BITOR:
case INST_BITXOR:
case INST_BITAND:
{
/*
* Only integers are allowed. We compute value op value2.
*/
long i2 = 0, rem, negative;
long iResult = 0; /* Init. avoids compiler warning. */
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w2, wResult = W0;
int doWide = 0;
#endif /* TCL_WIDE_INT_IS_LONG */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
} else if (valuePtr->typePtr == &tclWideIntType) {
w = valuePtr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
} 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")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
}
if (value2Ptr->typePtr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
} else if (value2Ptr->typePtr == &tclWideIntType) {
w2 = value2Ptr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
} 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")));
IllegalExprOperandType(interp, pc, value2Ptr);
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.
*/
#ifdef TCL_WIDE_INT_IS_LONG
if (i2 == 0) {
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
goto divideByZero;
}
#else /* !TCL_WIDE_INT_IS_LONG */
if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
if (valuePtr->typePtr == &tclIntType) {
LLTRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
} else {
LLTRACE((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 {
LLTRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
}
goto divideByZero;
}
#endif /* TCL_WIDE_INT_IS_LONG */
negative = 0;
#ifndef TCL_WIDE_INT_IS_LONG
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
Tcl_WideInt wRemainder;
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
if (w2 < 0) {
w2 = -w2;
w = -w;
negative = 1;
}
wRemainder = w % w2;
if (wRemainder < 0) {
wRemainder += w2;
}
if (negative) {
wRemainder = -wRemainder;
}
wResult = wRemainder;
doWide = 1;
break;
}
#endif /* TCL_WIDE_INT_IS_LONG */
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:
#ifndef TCL_WIDE_INT_IS_LONG
/*
* 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 << i2;
doWide = 1;
break;
}
#endif /* TCL_WIDE_INT_IS_LONG */
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.
*/
#ifndef TCL_WIDE_INT_IS_LONG
/*
* 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) >> i2);
} else {
wResult = w >> i2;
}
doWide = 1;
break;
}
#endif /* TCL_WIDE_INT_IS_LONG */
if (i < 0) {
iResult = ~((~i) >> i2);
} else {
iResult = i >> i2;
}
break;
case INST_BITOR:
#ifndef TCL_WIDE_INT_IS_LONG
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;
}
#endif /* TCL_WIDE_INT_IS_LONG */
iResult = i | i2;
break;
case INST_BITXOR:
#ifndef TCL_WIDE_INT_IS_LONG
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;
}
#endif /* TCL_WIDE_INT_IS_LONG */
iResult = i ^ i2;
break;
case INST_BITAND:
#ifndef TCL_WIDE_INT_IS_LONG
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;
}
#endif /* TCL_WIDE_INT_IS_LONG */
iResult = i & i2;
break;
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
#ifndef TCL_WIDE_INT_IS_LONG
if (doWide) {
objResultPtr = Tcl_NewWideIntObj(wResult);
LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
} else {
#endif /* TCL_WIDE_INT_IS_LONG */
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
#ifndef TCL_WIDE_INT_IS_LONG
}
#endif /* TCL_WIDE_INT_IS_LONG */
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
#ifndef TCL_WIDE_INT_IS_LONG
if (doWide) {
LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
Tcl_SetWideIntObj(valuePtr, wResult);
} else {
#endif /* TCL_WIDE_INT_IS_LONG */
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
#ifndef TCL_WIDE_INT_IS_LONG
}
#endif /* TCL_WIDE_INT_IS_LONG */
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 */
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w2, wquot, wrem;
Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
int doWide = 0; /* 1 if doing wide arithmetic. */
#endif /* TCL_WIDE_INT_IS_LONG */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if (t1Ptr == &tclIntType) {
i = valuePtr->internalRep.longValue;
#ifndef TCL_WIDE_INT_IS_LONG
} else if (t1Ptr == &tclWideIntType) {
w = valuePtr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
} 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.
*/
d1 = valuePtr->internalRep.doubleValue;
} else {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
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;
#ifndef TCL_WIDE_INT_IS_LONG
} else if (t2Ptr == &tclWideIntType) {
w2 = value2Ptr->internalRep.wideValue;
#endif /* TCL_WIDE_INT_IS_LONG */
} 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.
*/
d2 = value2Ptr->internalRep.doubleValue;
} else {
char *s = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
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 */
#ifndef TCL_WIDE_INT_IS_LONG
} else if (t1Ptr == &tclWideIntType) {
d1 = Tcl_WideAsDouble(w);
} else if (t2Ptr == &tclWideIntType) {
d2 = Tcl_WideAsDouble(w2);
#endif /* TCL_WIDE_INT_IS_LONG */
}
switch (*pc) {
case INST_ADD:
dResult = d1 + d2;
break;
case INST_SUB:
dResult = d1 - d2;
break;
case INST_MULT:
dResult = d1 * d2;
break;
case INST_DIV:
if (d2 == 0.0) {
TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
goto divideByZero;
}
dResult = d1 / d2;
break;
}
/*
* 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;
}
#ifndef TCL_WIDE_INT_IS_LONG
} else if ((t1Ptr == &tclWideIntType)
|| (t2Ptr == &tclWideIntType)) {
/*
* Do wide integer arithmetic.
*/
doWide = 1;
if (t1Ptr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (t2Ptr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
switch (*pc) {
case INST_ADD:
wResult = w + w2;
break;
case INST_SUB:
wResult = w - w2;
break;
case INST_MULT:
wResult = w * w2;
break;
case INST_DIV:
/*
* 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) {
LLTRACE((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;
}
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
/*
* Do integer arithmetic.
*/
switch (*pc) {
case INST_ADD:
iResult = i + i2;
break;
case INST_SUB:
iResult = i - i2;
break;
case INST_MULT:
iResult = i * i2;
break;
case INST_DIV:
/*
* 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 (i2 == 0) {
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
goto divideByZero;
}
if (i2 < 0) {
i2 = -i2;
i = -i;
}
quot = i / i2;
rem = i % i2;
if (rem < 0) {
quot -= 1;
}
iResult = quot;
break;
}
}
/*
* 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));
#ifndef TCL_WIDE_INT_IS_LONG
} else if (doWide) {
objResultPtr = Tcl_NewWideIntObj(wResult);
LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
#endif /* TCL_WIDE_INT_IS_LONG */
} 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);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (doWide) {
LLTRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
Tcl_SetWideIntObj(valuePtr, wResult);
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
}
NEXT_INST_F(1, 1, 0);
}
}
case INST_UPLUS:
{
/*
* Operand must be numeric.
*/
double d;
Tcl_ObjType *tPtr;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
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);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (tPtr == &tclWideIntType) {
w = valuePtr->internalRep.wideValue;
objResultPtr = Tcl_NewWideIntObj(w);
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
d = valuePtr->internalRep.doubleValue;
objResultPtr = Tcl_NewDoubleObj(d);
}
TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
NEXT_INST_F(1, 1, 1);
} else {
Tcl_InvalidateStringRep(valuePtr);
TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
NEXT_INST_F(1, 0, 0);
}
}
case INST_UMINUS:
case INST_LNOT:
{
/*
* The operand must be numeric or a boolean string as
* accepted by Tcl_GetBooleanFromObj(). If the operand
* object is unshared modify it directly, otherwise
* create a copy to modify: this is "copy on write".
* Free any old string representation since it is now
* invalid.
*/
double d;
int boolvar;
Tcl_ObjType *tPtr;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
valuePtr->typePtr = &tclIntType;
} else {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d);
}
if (result == TCL_ERROR && *pc == INST_LNOT) {
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);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (tPtr == &tclWideIntType) {
w = valuePtr->internalRep.wideValue;
if (*pc == INST_UMINUS) {
objResultPtr = Tcl_NewWideIntObj(-w);
} else {
objResultPtr = Tcl_NewLongObj(w == W0);
}
LLTRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
objResultPtr = Tcl_NewDoubleObj(-d);
} else {
/*
* Should be able to use "!d", but apparently
* some compilers can't handle it.
*/
objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
}
TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
}
NEXT_INST_F(1, 1, 1);
} else {
/*
* 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);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (tPtr == &tclWideIntType) {
w = valuePtr->internalRep.wideValue;
if (*pc == INST_UMINUS) {
Tcl_SetWideIntObj(valuePtr, -w);
} else {
Tcl_SetLongObj(valuePtr, w == W0);
}
LLTRACE_WITH_OBJ((LLD" => ", w), valuePtr);
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
Tcl_SetDoubleObj(valuePtr, -d);
} else {
/*
* Should be able to use "!d", but apparently
* some compilers can't handle it.
*/
Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
}
TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
}
NEXT_INST_F(1, 0, 0);
}
}
case INST_BITNOT:
{
/*
* The operand must be an integer. If the operand object is
* unshared modify it directly, otherwise modify a copy.
* Free any old string representation since it is now
* invalid.
*/
Tcl_ObjType *tPtr;
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;
}
}
#ifndef TCL_WIDE_INT_IS_LONG
if (valuePtr->typePtr == &tclWideIntType) {
w = valuePtr->internalRep.wideValue;
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewWideIntObj(~w);
LLTRACE(("0x%llx => (%llu)\n", w, ~w));
NEXT_INST_F(1, 1, 1);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
Tcl_SetWideIntObj(valuePtr, ~w);
LLTRACE(("0x%llx => (%llu)\n", w, ~w));
NEXT_INST_F(1, 0, 0);
}
} else {
#endif /* TCL_WIDE_INT_IS_LONG */
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);
}
#ifndef TCL_WIDE_INT_IS_LONG
}
#endif /* TCL_WIDE_INT_IS_LONG */
}
case INST_CALL_BUILTIN_FUNC1:
opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call one of the built-in Tcl math functions.
*/
BuiltinFunc *mathFuncPtr;
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
}
mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
DECACHE_STACK_INFO();
result = (*mathFuncPtr->proc)(interp, eePtr,
mathFuncPtr->clientData);
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
}
NEXT_INST_F(2, 0, 0);
case INST_CALL_FUNC1:
opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call a non-builtin Tcl math function previously
* registered by a call to Tcl_CreateMathFunc.
*/
int objc = opnd; /* Number of arguments. The function name
* is the 0-th argument. */
Tcl_Obj **objv; /* The array of arguments. The function
* name is objv[0]. */
objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
DECACHE_STACK_INFO();
result = ExprCallMathFunc(interp, eePtr, objc, objv);
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
}
NEXT_INST_F(2, 0, 0);
case INST_TRY_CVT_TO_NUMERIC:
{
/*
* Try to convert the topmost stack object to an int or
* double object. This is done in order to support Tcl's
* policy of interpreting operands if at all possible as
* first integers, else floating-point numbers.
*/
double d;
char *s;
Tcl_ObjType *tPtr;
int converted, needNew;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
converted = 0;
if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
valuePtr->typePtr = &tclIntType;
converted = 1;
} else {
s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d);
}
if (result == TCL_OK) {
converted = 1;
}
result = TCL_OK; /* reset the result variable */
}
tPtr = valuePtr->typePtr;
}
/*
* Ensure that the topmost stack object, if numeric, has a
* string rep the same as the formatted version of its
* internal rep. This is used, e.g., to make sure that "expr
* {0001}" yields "1", not "0001". 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. Also check if there has been an IEEE
* floating point error.
*/
objResultPtr = valuePtr;
needNew = 0;
if (IS_NUMERIC_TYPE(tPtr)) {
if (Tcl_IsShared(valuePtr)) {
if (valuePtr->bytes != NULL) {
/*
* 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);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (tPtr == &tclWideIntType) {
w = valuePtr->internalRep.wideValue;
objResultPtr = Tcl_NewWideIntObj(w);
#endif /* TCL_WIDE_INT_IS_LONG */
} 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)));
TclExprFloatError(interp, d);
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:
Tcl_ResetResult(interp);
result = TCL_BREAK;
cleanup = 0;
goto processExceptionReturn;
case INST_CONTINUE:
Tcl_ResetResult(interp);
result = TCL_CONTINUE;
cleanup = 0;
goto processExceptionReturn;
case INST_FOREACH_START4:
opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* Initialize the temporary local var that holds the count
* of the number of iterations of the loop body to -1.
*/
ForeachInfo *infoPtr = (ForeachInfo *)
codePtr->auxDataArrayPtr[opnd].clientData;
int iterTmpIndex = infoPtr->loopCtTemp;
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
} else {
Tcl_SetLongObj(oldValuePtr, -1);
}
TclSetVarScalar(iterVarPtr);
TclClearVarUndefined(iterVarPtr);
TRACE(("%u => loop iter count temp %d\n",
opnd, iterTmpIndex));
}
#ifndef TCL_COMPILE_DEBUG
/*
* Remark that the compiler ALWAYS sets INST_FOREACH_STEP4
* immediately after INST_FOREACH_START4 - let us just fall
* through instead of jumping back to the top.
*/
pc += 5;
#else
NEXT_INST_F(5, 0, 0);
#endif
case INST_FOREACH_STEP4:
opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* "Step" a foreach loop (i.e., begin its next iteration) by
* assigning the next value list element to each loop var.
*/
ForeachInfo *infoPtr = (ForeachInfo *)
codePtr->auxDataArrayPtr[opnd].clientData;
ForeachVarList *varListPtr;
int numLists = infoPtr->numLists;
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Tcl_Obj *listPtr;
List *listRepPtr;
Var *iterVarPtr, *listVarPtr;
int iterNum, listTmpIndex, listLen, numVars;
int varIndex, valIndex, continueLoop, j;
/*
* Increment the temp holding the loop iteration number.
*/
iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
valuePtr = iterVarPtr->value.objPtr;
iterNum = (valuePtr->internalRep.longValue + 1);
Tcl_SetLongObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should
* stop the loop.
*/
continueLoop = 0;
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
result = Tcl_ListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
goto checkForCatch;
}
if (listLen > (iterNum * numVars)) {
continueLoop = 1;
}
listTmpIndex++;
}
/*
* If some var in some var list still has a remaining list
* element iterate one more time. Assign to var the next
* element from its value list. We already checked above
* that each list temp holds a valid list object.
*/
if (continueLoop) {
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
listLen = listRepPtr->elemCount;
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
int setEmptyStr = 0;
if (valIndex >= listLen) {
setEmptyStr = 1;
TclNewObj(valuePtr);
} else {
valuePtr = listRepPtr->elements[valIndex];
}
varIndex = varListPtr->varIndexes[j];
varPtr = &(varFramePtr->compiledLocals[varIndex]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL))
&& (varPtr->tracePtr == NULL)
&& (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) {
value2Ptr = varPtr->value.objPtr;
if (valuePtr != value2Ptr) {
if (value2Ptr != NULL) {
TclDecrRefCount(value2Ptr);
} else {
TclSetVarScalar(varPtr);
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));
if (setEmptyStr) {
TclDecrRefCount(valuePtr);
}
result = TCL_ERROR;
goto checkForCatch;
}
}
valIndex++;
}
listTmpIndex++;
}
}
TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
iterNum, (continueLoop? "continue" : "exit")));
/*
* Run-time peep-hole optimisation: the compiler ALWAYS follows
* INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
* instruction and jump direct from here.
*/
pc += 5;
if (*pc == INST_JUMP_FALSE1) {
NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
} else {
NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
}
}
case INST_BEGIN_CATCH4:
/*
* Record start of the catch command with exception range index
* equal to the operand. Push the current stack depth onto the
* special catch stack.
*/
catchStackPtr[++catchTop] = stackTop;
TRACE(("%u => catchTop=%d, stackTop=%d\n",
TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
NEXT_INST_F(5, 0, 0);
case INST_END_CATCH:
catchTop--;
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));
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:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
(char *) NULL);
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.
*/
processExceptionReturn:
#if TCL_COMPILE_DEBUG
switch (*pc) {
case INST_INVOKE_STK1:
case INST_INVOKE_STK4:
TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
break;
case INST_EVAL_STK:
/*
* Note that the object at stacktop has to be used
* before doing the cleanup.
*/
TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop])));
break;
default:
TRACE(("=> "));
}
#endif
if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
if (rangePtr == NULL) {
TRACE_APPEND(("no encl. loop or catch, returning %s\n",
StringForResultCode(result)));
goto abnormalReturn;
}
if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
goto processCatch;
}
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
if (result == TCL_BREAK) {
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->breakOffset);
TRACE_APPEND(("%s, range at %d, new pc %d\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->breakOffset));
NEXT_INST_F(0, 0, 0);
} else {
if (rangePtr->continueOffset == -1) {
TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
StringForResultCode(result)));
goto checkForCatch;
}
result = TCL_OK;
pc = (codePtr->codeStart + rangePtr->continueOffset);
TRACE_APPEND(("%s, range at %d, new pc %d\n",
StringForResultCode(result),
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
}
#if TCL_COMPILE_DEBUG
} else if (traceInstructions) {
if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
result, O2S(objPtr)));
} else {
objPtr = Tcl_GetObjResult(interp);
TRACE_APPEND(("%s, result= \"%s\"\n",
StringForResultCode(result), O2S(objPtr)));
}
#endif
}
/*
* Execution has generated an "exception" such as TCL_ERROR. If the
* exception is an error, record information about what was being
* executed when the error occurred. Find the closest enclosing
* catch range, if any. If no enclosing catch range is found, stop
* 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",
StringForResultCode(result));
}
#endif
goto abnormalReturn;
}
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
if (rangePtr == NULL) {
/*
* This is only possible when compiling a [catch] that sends its
* script to INST_EVAL. Cannot correct the compiler without
* breakingcompat with previous .tbc compiled scripts.
*/
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %s\n",
StringForResultCode(result));
}
#endif
goto abnormalReturn;
}
/*
* A catch exception range (rangePtr) was found to handle an
* "exception". It was found either by checkForCatch just above or
* by an instruction during break, continue, or error processing.
* Jump to its catchOffset after unwinding the operand stack to
* the depth it had when starting to execute the range's catch
* command.
*/
processCatch:
while (stackTop > catchStackPtr[catchTop]) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
(unsigned int)(rangePtr->catchOffset));
}
#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */
/*
* end of infinite loop dispatching on instructions.
*/
/*
* Abnormal return code. Restore the stack to state it had when starting
* to execute the ByteCode. Panic if the stack is below the initial level.
*/
abnormalReturn:
while (stackTop > initStackTop) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
if (stackTop < initStackTop) {
fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
(unsigned int)(pc - codePtr->codeStart),
(unsigned int) stackTop,
(unsigned int) initStackTop);
panic("TclExecuteByteCode execution failure: end stack top < start stack top");
}
/*
* Free the catch stack array if malloc'ed storage was used.
|
| ︙ | ︙ | |||
4572 4573 4574 4575 4576 4577 4578 |
Tcl_ResetResult(interp);
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't use empty string as operand of \"",
operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
} else {
char *msg = "non-numeric string";
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > | | > | | | > | 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 |
Tcl_ResetResult(interp);
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't use empty string as operand of \"",
operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
} else {
char *msg = "non-numeric string";
char *s, *p;
int length;
int looksLikeInt = 0;
s = Tcl_GetStringFromObj(opndPtr, &length);
p = s;
/*
* strtod() isn't at all consistent about detecting Inf and
* NaN between platforms.
*/
if (length == 3) {
if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') &&
(s[2]=='n' || s[2]=='N')) {
msg = "non-numeric floating-point value";
goto makeErrorMessage;
}
if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') &&
(s[2]=='f' || s[2]=='F')) {
msg = "infinite floating-point value";
goto makeErrorMessage;
}
}
/*
* We cannot use TclLooksLikeInt here because it passes strings
* like "10;" [Bug 587140]. We'll accept as "looking like ints"
* for the present purposes any string that looks formally like
* a (decimal|octal|hex) integer.
*/
while (length && isspace(UCHAR(*p))) {
length--;
p++;
}
if (length && ((*p == '+') || (*p == '-'))) {
length--;
p++;
}
if (length) {
if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) {
p += 2;
length -= 2;
looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
if (looksLikeInt) {
length--;
p++;
while (length && isxdigit(UCHAR(*p))) {
length--;
p++;
}
}
} else {
looksLikeInt = (length && isdigit(UCHAR(*p)));
if (looksLikeInt) {
length--;
p++;
while (length && isdigit(UCHAR(*p))) {
length--;
p++;
}
}
}
while (length && isspace(UCHAR(*p))) {
length--;
p++;
}
looksLikeInt = !length;
}
if (looksLikeInt) {
/*
* If something that looks like an integer could not be
* converted, then it *must* be a bad octal or too large
* to represent [Bug 542588].
*/
if (TclCheckBadOctal(NULL, s)) {
msg = "invalid octal number";
} else {
msg = "integer value too large to represent";
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
}
} else {
/*
* See if the operand can be interpreted as a double in
* order to improve the error message.
*/
double d;
if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
msg = "floating-point value";
}
}
makeErrorMessage:
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
"\"", (char *) NULL);
}
}
/*
|
| ︙ | ︙ | |||
4771 4772 4773 4774 4775 4776 4777 |
ByteCode* codePtr; /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
register ExceptionRange *rangePtr;
int pcOffset = (pc - codePtr->codeStart);
| | | > > > > > > | < | | | < | > | | | < < | 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 |
ByteCode* codePtr; /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
register ExceptionRange *rangePtr;
int pcOffset = (pc - codePtr->codeStart);
register int start;
if (numRanges == 0) {
return NULL;
}
/*
* This exploits peculiarities of our compiler: nested ranges
* are always *after* their containing ranges, so that by scanning
* backwards we are sure that the first matching range is indeed
* the deepest.
*/
rangeArrayPtr = codePtr->exceptArrayPtr;
rangePtr = rangeArrayPtr + numRanges;
while (--rangePtr >= rangeArrayPtr) {
start = rangePtr->codeOffset;
if ((start <= pcOffset) &&
(pcOffset < (start + rangePtr->numCodeBytes))) {
if ((!catchOnly)
|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
return rangePtr;
}
}
}
return NULL;
}
/*
|
| ︙ | ︙ | |||
4822 4823 4824 4825 4826 4827 4828 |
static char *
GetOpcodeName(pc)
unsigned char *pc; /* Points to the instruction whose name
* should be returned. */
{
unsigned char opCode = *pc;
| | | 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 |
static char *
GetOpcodeName(pc)
unsigned char *pc; /* Points to the instruction whose name
* should be returned. */
{
unsigned char opCode = *pc;
return tclInstructionTable[opCode].name;
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* VerifyExprObjType --
|
| ︙ | ︙ | |||
5711 5712 5713 5714 5715 5716 5717 |
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = i;
#ifndef TCL_WIDE_INT_IS_LONG
} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = Tcl_LongAsWide(i);
| | | | | 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 |
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = i;
#ifndef TCL_WIDE_INT_IS_LONG
} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = Tcl_LongAsWide(i);
#endif /* !TCL_WIDE_INT_IS_LONG */
} else {
args[k].type = TCL_INT;
args[k].intValue = i;
}
#ifndef TCL_WIDE_INT_IS_LONG
} else if (valuePtr->typePtr == &tclWideIntType) {
Tcl_WideInt w = valuePtr->internalRep.wideValue;
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].wideValue = (Tcl_WideInt) Tcl_WideAsDouble(w);
} else if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].wideValue = Tcl_WideAsLong(w);
} else {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = w;
}
#endif /* !TCL_WIDE_INT_IS_LONG */
} else {
d = valuePtr->internalRep.doubleValue;
if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].intValue = (long) d;
#ifndef TCL_WIDE_INT_IS_LONG
} else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
args[k].type = TCL_WIDE_INT;
args[k].wideValue = Tcl_DoubleAsWide(d);
#endif /* !TCL_WIDE_INT_IS_LONG */
} else {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = d;
}
}
}
|
| ︙ | ︙ | |||
5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 |
/*
* Push the call's object result.
*/
if (funcResult.type == TCL_INT) {
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
} else {
d = funcResult.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
| > > > > | 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 |
/*
* Push the call's object result.
*/
if (funcResult.type == TCL_INT) {
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
#ifndef TCL_WIDE_INT_IS_LONG
} else if (funcResult.type == TCL_WIDE_INT) {
PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue));
#endif /* !TCL_WIDE_INT_IS_LONG */
} else {
d = funcResult.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
|
| ︙ | ︙ | |||
6253 6254 6255 6256 6257 6258 6259 |
* Instruction counts.
*/
fprintf(stdout, "\nInstruction counts:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i]) {
fprintf(stdout, "%20s %8ld %6.1f%%\n",
| | | < | 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 |
* Instruction counts.
*/
fprintf(stdout, "\nInstruction counts:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i]) {
fprintf(stdout, "%20s %8ld %6.1f%%\n",
tclInstructionTable[i].name,
statsPtr->instructionCount[i],
(statsPtr->instructionCount[i]*100.0) / numInstructions);
}
}
fprintf(stdout, "\nInstructions NEVER executed:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i] == 0) {
fprintf(stdout, "%20s\n", tclInstructionTable[i].name);
}
}
#ifdef TCL_MEM_DEBUG
fprintf(stdout, "\nHeap Statistics:\n");
TclDumpMemoryInfo(stdout);
#endif
|
| ︙ | ︙ |
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.13.8.3 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * Declarations for local procedures defined in this file: |
| ︙ | ︙ | |||
444 445 446 447 448 449 450 451 452 453 454 455 456 457 |
* rename them. */
int force; /* If non-zero, overwrite target file if it
* exists. Otherwise, error if target already
* exists. */
{
int result;
Tcl_Obj *errfile, *errorBuffer;
Tcl_StatBuf sourceStatBuf, targetStatBuf;
if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
| > > | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
* rename them. */
int force; /* If non-zero, overwrite target file if it
* exists. Otherwise, error if target already
* exists. */
{
int result;
Tcl_Obj *errfile, *errorBuffer;
/* If source is a link, then this is the real file/directory */
Tcl_Obj *actualSource = NULL;
Tcl_StatBuf sourceStatBuf, targetStatBuf;
if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 551 552 |
/*
* The rename failed because the move was across file systems.
* Fall through to copy file and then remove original. Note that
* the low-level Tcl_FSRenameFileProc in the filesystem is allowed
* to implement cross-filesystem moves itself, if it desires.
*/
}
if (S_ISDIR(sourceStatBuf.st_mode)) {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
/*
* The rename failed because the move was across file systems.
* Fall through to copy file and then remove original. Note that
* the low-level Tcl_FSRenameFileProc in the filesystem is allowed
* to implement cross-filesystem moves itself, if it desires.
*/
}
actualSource = source;
Tcl_IncrRefCount(actualSource);
#if 0
#ifdef S_ISLNK
/*
* To add a flag to make 'copy' copy links instead of files, we could
* add a condition to ignore this 'if' here.
*/
if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
/*
* We want to copy files not links. Therefore we must follow the
* link. There are two purposes to this 'stat' call here. First
* we want to know if the linked-file/dir actually exists, and
* second, in the block of code which follows, some 20 lines
* down, we want to check if the thing is a file or directory.
*/
if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
/* Actual file doesn't exist */
Tcl_AppendResult(interp,
"error copying \"", Tcl_GetString(source),
"\": the target of this link doesn't exist",
(char *) NULL);
goto done;
} else {
int counter = 0;
while (1) {
Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
if (path == NULL) {
break;
}
Tcl_DecrRefCount(actualSource);
actualSource = path;
counter++;
/* Arbitrary limit of 20 links to follow */
if (counter > 20) {
/* Too many links */
Tcl_SetErrno(EMLINK);
errfile = source;
goto done;
}
}
/* Now 'actualSource' is the correct file */
}
}
#endif
#endif
if (S_ISDIR(sourceStatBuf.st_mode)) {
result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
if (result != TCL_OK) {
if (errno == EXDEV) {
/*
* The copy failed because we're trying to do a
* cross-filesystem copy. We do this through our Tcl
* library.
*/
|
| ︙ | ︙ | |||
594 595 596 597 598 599 600 |
errfile = source;
} else if (Tcl_FSEqualPaths(errfile, target)) {
errfile = target;
}
}
}
} else {
| | | 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
errfile = source;
} else if (Tcl_FSEqualPaths(errfile, target)) {
errfile = target;
}
}
}
} else {
result = Tcl_FSCopyFile(actualSource, target);
if ((result != TCL_OK) && (errno == EXDEV)) {
result = TclCrossFilesystemCopy(interp, source, target);
}
if (result != TCL_OK) {
/*
* We could examine 'errno' to double-check if the problem
* was with the target, but we checked the source above,
|
| ︙ | ︙ | |||
648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
}
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
(char *) NULL);
}
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* FileForceOption --
| > > > | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 |
}
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
(char *) NULL);
}
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
if (actualSource != NULL) {
Tcl_DecrRefCount(actualSource);
}
return result;
}
/*
*---------------------------------------------------------------------------
*
* FileForceOption --
|
| ︙ | ︙ | |||
824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 |
if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
return TCL_ERROR;
}
objc -= 3;
objv += 3;
result = TCL_ERROR;
attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
if (attributeStrings == NULL) {
int index;
Tcl_Obj *objPtr;
if (objStrings == NULL) {
goto end;
}
/* We own the object now */
Tcl_IncrRefCount(objStrings);
/* Use objStrings as a list object */
if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
| > > > > > > > > > > > > | 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 |
if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
return TCL_ERROR;
}
objc -= 3;
objv += 3;
result = TCL_ERROR;
Tcl_SetErrno(0);
attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
if (attributeStrings == NULL) {
int index;
Tcl_Obj *objPtr;
if (objStrings == NULL) {
if (Tcl_GetErrno() != 0) {
/*
* There was an error, probably that the filePtr is
* not accepted by any filesystem
*/
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not read \"", Tcl_GetString(filePtr),
"\": ", Tcl_PosixError(interp),
(char *) NULL);
return TCL_ERROR;
}
goto end;
}
/* We own the object now */
Tcl_IncrRefCount(objStrings);
/* Use objStrings as a list object */
if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
|
| ︙ | ︙ |
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 | /* * 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.38.2.3 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclIO.h" #include <assert.h> |
| ︙ | ︙ | |||
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 |
int srcLen; /* Length of UTF-8 string in bytes. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
char *dst, *stage;
int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
int stageLen, toWrite, stageRead, endEncoding, result;
Tcl_Encoding encoding;
char safe[BUFFER_PADDING];
total = 0;
sawLF = 0;
savedLF = 0;
saved = 0;
encoding = statePtr->encoding;
/*
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
/*
* Loop over all UTF-8 characters in src, storing them in staging buffer
* with proper EOL translation.
*/
| > > | > | 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 |
int srcLen; /* Length of UTF-8 string in bytes. */
{
ChannelState *statePtr = chanPtr->state; /* state info for channel */
ChannelBuffer *bufPtr;
char *dst, *stage;
int saved, savedLF, sawLF, total, dstLen, stageMax, dstWrote;
int stageLen, toWrite, stageRead, endEncoding, result;
int consumedSomething;
Tcl_Encoding encoding;
char safe[BUFFER_PADDING];
total = 0;
sawLF = 0;
savedLF = 0;
saved = 0;
encoding = statePtr->encoding;
/*
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
/*
* Loop over all UTF-8 characters in src, storing them in staging buffer
* with proper EOL translation.
*/
consumedSomething = 1;
while (consumedSomething && (srcLen + savedLF + endEncoding > 0)) {
consumedSomething = 0;
stage = statePtr->outputStage;
stageMax = statePtr->bufSize;
stageLen = stageMax;
toWrite = stageLen;
if (toWrite > srcLen) {
toWrite = srcLen;
|
| ︙ | ︙ | |||
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 |
}
total += dstWrote;
stage += stageRead;
stageLen -= stageRead;
sawLF = 0;
/*
* If all translated characters are written to the buffer,
* endEncoding is set to 0 because the escape sequence may be
* output.
*/
if ((stageLen + saved == 0) && (result == 0)) {
endEncoding = 0;
}
}
}
return total;
}
/*
*---------------------------------------------------------------------------
*
* TranslateOutputEOL --
| > > > > > > > > > > > | 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 |
}
total += dstWrote;
stage += stageRead;
stageLen -= stageRead;
sawLF = 0;
consumedSomething = 1;
/*
* If all translated characters are written to the buffer,
* endEncoding is set to 0 because the escape sequence may be
* output.
*/
if ((stageLen + saved == 0) && (result == 0)) {
endEncoding = 0;
}
}
}
/* If nothing was written and it happened because there was no progress
* in the UTF conversion, we throw an error.
*/
if (!consumedSomething && (total == 0)) {
Tcl_SetErrno (EINVAL);
return -1;
}
return total;
}
/*
*---------------------------------------------------------------------------
*
* TranslateOutputEOL --
|
| ︙ | ︙ |
Changes to generic/tclIOSock.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclIOSock.c -- * * Common routines used by all socket based channel types. * * 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 | /* * tclIOSock.c -- * * Common routines used by all socket based channel types. * * 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: tclIOSock.c,v 1.5.18.2 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclPort.h" /* *--------------------------------------------------------------------------- |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 |
int
TclSockMinimumBuffers(sock, size)
int sock; /* Socket file descriptor */
int size; /* Minimum buffer size */
{
int current;
| < < < | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
int
TclSockMinimumBuffers(sock, size)
int sock; /* Socket file descriptor */
int size; /* Minimum buffer size */
{
int current;
socklen_t len;
len = sizeof(int);
getsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)¤t, &len);
if (current < size) {
len = sizeof(int);
setsockopt(sock, SOL_SOCKET, SO_SNDBUF, (char *)&size, len);
}
|
| ︙ | ︙ |
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 | * * 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.22.2.3 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #ifdef MAC_TCL #include "tclMacInt.h" #endif #ifdef __WIN32__ /* for tclWinProcs->useWide */ #include "tclWinInt.h" #endif /* * Prototypes for procedures defined later in this file. */ static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); |
| ︙ | ︙ | |||
310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
int fileRefCount; /* How many Tcl_Obj's use this
* filesystem. */
struct FilesystemRecord *nextPtr;
/* The next filesystem registered
* to Tcl, or NULL if no more. */
} FilesystemRecord;
/*
* 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.
*
| > > > | 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 |
int fileRefCount; /* How many Tcl_Obj's use this
* filesystem. */
struct FilesystemRecord *nextPtr;
/* The next filesystem registered
* to Tcl, or NULL if no more. */
} FilesystemRecord;
static FilesystemRecord* GetFilesystemRecord
_ANSI_ARGS_((Tcl_Filesystem *fromFilesystem, int *epoch));
/*
* 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.
*
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 | Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; Tcl_FSUnloadFileProc TclpUnloadFile; Tcl_FSLinkProc TclpObjLink; Tcl_FSListVolumesProc TclpObjListVolumes; | > | > > > > > > | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
Tcl_FSUnloadFileProc TclpUnloadFile;
Tcl_FSLinkProc TclpObjLink;
Tcl_FSListVolumesProc TclpObjListVolumes;
/*
* 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!
*/
static Tcl_Filesystem tclNativeFilesystem = {
"native",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
&NativePathInFilesystem,
&NativeDupInternalRep,
&NativeFreeInternalRep,
&TclpNativeToNormalized,
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 |
&TclpObjCreateDirectory,
&TclpObjRemoveDirectory,
&TclpObjDeleteFile,
&TclpObjCopyFile,
&TclpObjRenameFile,
&TclpObjCopyDirectory,
&TclpObjLstat,
| | | | > > | > > | > > | > | > | > | 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 |
&TclpObjCreateDirectory,
&TclpObjRemoveDirectory,
&TclpObjDeleteFile,
&TclpObjCopyFile,
&TclpObjRenameFile,
&TclpObjCopyDirectory,
&TclpObjLstat,
&TclpDlopen,
&TclpObjGetCwd,
&TclpObjChdir
};
/*
* Define the tail of the linked list. Note that for unconventional
* uses of Tcl without a native filesystem, we may in the future wish
* to modify the current approach of hard-coding the native filesystem
* in the lookup list 'filesystemList' below.
*
* We initialize the record so that it thinks one file uses it. This
* means it will never be freed.
*/
static FilesystemRecord nativeFilesystemRecord = {
NULL,
&tclNativeFilesystem,
1,
NULL
};
/*
* The following few variables are protected by the
* filesystemMutex just below.
*/
/*
* 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.
*/
static int theFilesystemEpoch = 0;
/*
* Stores the linked list of filesystems.
*/
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
/*
* The number of loops which are currently iterating over the linked
* list. If this is greater than zero, we can't modify the list.
*/
static int filesystemIteratorsInProgress = 0;
/*
* Someone wants to modify the list of filesystems if this is set.
*/
static int filesystemWantToModify = 0;
#ifdef TCL_THREADS
static Tcl_Condition filesystemOkToModify = NULL;
#endif
TCL_DECLARE_MUTEX(filesystemMutex)
/*
* struct FsPath --
*
* Internal representation of a Tcl_Obj of "path" type. This
|
| ︙ | ︙ | |||
503 504 505 506 507 508 509 |
* file from a file system by way of making a temporary copy of the
* file on the native filesystem. We need to store both the actual
* unloadProc/clientData combination which was used, and the original
* and modified filenames, so that we can correctly undo the entire
* operation when we want to unload the code.
*/
typedef struct FsDivertLoad {
| | | 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
* file from a file system by way of making a temporary copy of the
* file on the native filesystem. We need to store both the actual
* unloadProc/clientData combination which was used, and the original
* and modified filenames, so that we can correctly undo the entire
* operation when we want to unload the code.
*/
typedef struct FsDivertLoad {
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *divertedFile;
Tcl_Filesystem *divertedFilesystem;
ClientData divertedFileNativeRep;
} FsDivertLoad;
/* Now move on to the basic filesystem implementation */
|
| ︙ | ︙ | |||
558 559 560 561 562 563 564 | *---------------------------------------------------------------------- * * TclFinalizeFilesystem -- * * Clean up the filesystem. After this, calls to all Tcl_FS... * functions will fail. * | | | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 | *---------------------------------------------------------------------- * * TclFinalizeFilesystem -- * * Clean up the filesystem. After this, calls to all Tcl_FS... * functions will fail. * * Note that, since 'TclFinalizeLoad' may unload extensions * which implement other filesystems, and which may therefore * contain a 'freeProc' for those filesystems, at this stage * we _must_ have freed all objects of "path" type, or we may * end up with segfaults if we try to free them later. * * Results: * None. |
| ︙ | ︙ | |||
1707 1708 1709 1710 1711 1712 1713 |
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
if (proc != NULL) {
| > > > > > | > > > > > > > > > | > > > > > > > > > > > > > > | 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 |
return retVal;
}
#endif /* USE_OBSOLETE_FS_HOOKS */
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) {
return NULL;
}
retVal = (*proc)(interp, pathPtr, mode, permissions);
if (retVal != NULL) {
if (seekFlag) {
if (Tcl_Seek(retVal, (Tcl_WideInt)0,
SEEK_END) < (Tcl_WideInt)0) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"could not seek to end of file while opening \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
Tcl_Close(NULL, retVal);
return NULL;
}
}
}
return retVal;
}
}
/* File doesn't belong to any filesystem that can open it */
Tcl_SetErrno(ENOENT);
if (interp != NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 |
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
*/
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
| > | 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 |
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
|
| ︙ | ︙ | |||
1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 |
}
Tcl_DecrRefCount(tmpResultPtr);
}
}
Tcl_DecrRefCount(cwd);
return ret;
}
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSGetCwd --
| > | 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 |
}
Tcl_DecrRefCount(tmpResultPtr);
}
}
Tcl_DecrRefCount(cwd);
return ret;
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSGetCwd --
|
| ︙ | ︙ | |||
2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
if (proc != NULL) {
return (*proc)(pathPtr, objPtrRef);
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrsGet --
| > | 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
if (proc != NULL) {
return (*proc)(pathPtr, objPtrRef);
}
}
Tcl_SetErrno(ENOENT);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrsGet --
|
| ︙ | ︙ | |||
2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
if (proc != NULL) {
return (*proc)(interp, index, pathPtr, objPtrRef);
}
}
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrsSet --
| > | 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
if (proc != NULL) {
return (*proc)(interp, index, pathPtr, objPtrRef);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrsSet --
|
| ︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
if (proc != NULL) {
return (*proc)(interp, index, pathPtr, objPtr);
}
}
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSChdir --
| > | 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
if (proc != NULL) {
return (*proc)(interp, index, pathPtr, objPtr);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSChdir --
|
| ︙ | ︙ | |||
2430 2431 2432 2433 2434 2435 2436 | * paths are always used. * * Results: * A standard Tcl completion code. If an error occurs, an error * message is left in the interp's result. * * Side effects: | | < | | | | | > > | > > > > > > > > | 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 |
* paths are always used.
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
* message is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory. This may later be
* unloaded by passing the clientData to the unloadProc.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
handlePtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code. */
CONST char *sym1, *sym2; /* Names of two procedures to look up in
* the file's symbol table. */
Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
/* Where to return the addresses corresponding
* to sym1 and sym2. */
Tcl_LoadHandle *handlePtr; /* 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_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
if (proc != NULL) {
int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
if (retVal != TCL_OK) {
return retVal;
}
if (*handlePtr == NULL) {
return TCL_ERROR;
}
if (sym1 != NULL) {
*proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
}
if (sym2 != NULL) {
*proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
}
return retVal;
} else {
Tcl_Filesystem *copyFsPtr;
Tcl_Obj *copyToPtr;
/* First check if it is readable -- and exists! */
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
|
| ︙ | ︙ | |||
2514 2515 2516 2517 2518 2519 2520 |
*
* Tcl_Obj* perm = Tcl_NewStringObj("0777",-1);
* Tcl_IncrRefCount(perm);
* Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);
* Tcl_DecrRefCount(perm);
*
*/
| | | > | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*
* Tcl_Obj* perm = Tcl_NewStringObj("0777",-1);
* Tcl_IncrRefCount(perm);
* Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);
* Tcl_DecrRefCount(perm);
*
*/
Tcl_LoadHandle newLoadHandle = NULL;
Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
FsDivertLoad *tvdlPtr;
int retVal;
retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2,
proc1Ptr, proc2Ptr,
&newLoadHandle,
&newUnloadProcPtr);
if (retVal != TCL_OK) {
/* The file didn't load successfully */
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return retVal;
}
/*
* Try to delete the file immediately -- this is
* possible in some OSes, and avoids any worries
* about leaving the copy laying around on exit.
*/
if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
Tcl_DecrRefCount(copyToPtr);
(*handlePtr) = NULL;
(*unloadProcPtr) = NULL;
return TCL_OK;
}
/*
* When we unload this file, we need to divert the
* unloading so we can unload and cleanup the
* temporary file correctly.
*/
tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad));
/*
* Remember three pieces of information. This allows
* us to cleanup the diverted load completely, on
* platforms which allow proper unloading of code.
*/
tvdlPtr->loadHandle = newLoadHandle;
tvdlPtr->unloadProcPtr = newUnloadProcPtr;
/* copyToPtr is already incremented for this reference */
tvdlPtr->divertedFile = copyToPtr;
/*
* This is the filesystem we loaded it into. It is
* almost certainly the tclNativeFilesystem, but we don't
* want to make that assumption. Since we have a
* reference to 'copyToPtr', we already have a refCount
* on this filesystem, so we don't need to worry about it
* disappearing on us.
*/
tvdlPtr->divertedFilesystem = copyFsPtr;
/* Get the native representation of the file path */
tvdlPtr->divertedFileNativeRep = Tcl_FSGetInternalRep(copyToPtr,
copyFsPtr);
copyToPtr = NULL;
(*handlePtr) = (Tcl_LoadHandle) tvdlPtr;
(*unloadProcPtr) = &FSUnloadTempFile;
return retVal;
} else {
/* Cross-platform copy failed */
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return TCL_ERROR;
}
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
* This function used to be in the platform specific directories, but it
* has now been made to work cross-platform
*/
int
TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
clientDataPtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *pathPtr; /* Name of the file containing the desired
* code (UTF-8). */
CONST char *sym1, *sym2; /* Names of two procedures to look up in
* the file's symbol table. */
Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
/* Where to return the addresses corresponding
* to sym1 and sym2. */
ClientData *clientDataPtr; /* 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_LoadHandle handle = NULL;
int res;
res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr);
if (res != TCL_OK) {
return res;
}
if (handle == NULL) {
return TCL_ERROR;
}
*clientDataPtr = (ClientData)handle;
*proc1Ptr = TclpFindSymbol(interp, handle, sym1);
*proc2Ptr = TclpFindSymbol(interp, handle, sym2);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
* FSUnloadTempFile --
*
* This function is called when we loaded a library of code via
|
| ︙ | ︙ | |||
2603 2604 2605 2606 2607 2608 2609 | * Side effects: * The effects of the 'unload' function called, and of course * the temporary file will be deleted. * *--------------------------------------------------------------------------- */ static void | | | | | | | 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 |
* Side effects:
* The effects of the 'unload' function called, and of course
* the temporary file will be deleted.
*
*---------------------------------------------------------------------------
*/
static void
FSUnloadTempFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to Tcl_FSLoadFile(). The loadHandle is
* a token that represents the loaded
* file. */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle;
/*
* This test should never trigger, since we give
* the client data in the function above.
*/
if (tvdlPtr == NULL) { return; }
/*
* Call the real 'unloadfile' proc we actually used. It is very
* important that we call this first, so that the shared library
* is actually unloaded by the OS. Otherwise, the following
* 'delete' may well fail because the shared library is still in
* use.
*/
if (tvdlPtr->unloadProcPtr != NULL) {
(*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);
}
/* Remove the temporary file we created. */
if (Tcl_FSDeleteFile(tvdlPtr->divertedFile) != TCL_OK) {
/*
* The above may have failed because the filesystem, or something
* it depends upon (e.g. encodings) are being taken down because
|
| ︙ | ︙ | |||
2679 2680 2681 2682 2683 2684 2685 | * Results: * If toPtr is NULL, then the result is a Tcl_Obj specifying the * contents of the symbolic link given by 'pathPtr', or NULL if * the symbolic link could not be read. The result is owned by * the caller, which should call Tcl_DecrRefCount when the result * is no longer needed. * | | | > > > > > < < < | > | > | > > | 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 |
* Results:
* If toPtr is NULL, then the result is a Tcl_Obj specifying the
* contents of the symbolic link given by 'pathPtr', or NULL if
* the symbolic link could not be read. The result is owned by
* the caller, which should call Tcl_DecrRefCount when the result
* is no longer needed.
*
* If toPtr is non-NULL, then the result is toPtr if the link action
* was successful, or NULL if not. In this case the result has no
* additional reference count, and need not be freed. The actual
* action to perform is given by the 'linkAction' flags, which is
* an or'd combination of:
*
* TCL_CREATE_SYMBOLIC_LINK
* TCL_CREATE_HARD_LINK
*
* Note that most filesystems will not support linking across
* to different filesystems, so this function will usually
* fail unless toPtr is in the same FS as pathPtr.
*
* Side effects:
* See readlink() documentation. A new filesystem link
* object may appear
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr; /* Path of file to readlink or link */
Tcl_Obj *toPtr; /* NULL or path to be linked to */
int linkAction; /* Action to perform */
{
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSLinkProc *proc = fsPtr->linkProc;
if (proc != NULL) {
return (*proc)(pathPtr, toPtr, linkAction);
}
}
/*
* If S_IFLNK isn't defined it means that the machine doesn't
* support symbolic links, so the file can't possibly be a
* symbolic link. Generate an EINVAL error, which is what
* happens on machines that do support symbolic links when
* you invoke readlink on a file that isn't a symbolic link.
*/
#ifndef S_IFLNK
errno = EINVAL;
#else
Tcl_SetErrno(ENOENT);
#endif /* S_IFLNK */
return NULL;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2883 2884 2885 2886 2887 2888 2889 |
/*
* Perform platform specific splitting.
*/
if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength)
== TCL_PATH_ABSOLUTE) {
| | | 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 |
/*
* Perform platform specific splitting.
*/
if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength)
== TCL_PATH_ABSOLUTE) {
if (fsPtr == &tclNativeFilesystem) {
return TclpNativeSplitPath(pathPtr, lenPtr);
}
} else {
return TclpNativeSplitPath(pathPtr, lenPtr);
}
/* We assume separators are single characters */
|
| ︙ | ︙ | |||
3037 3038 3039 3040 3041 3042 3043 | * 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; | | | 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 |
* 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);
|
| ︙ | ︙ | |||
3141 3142 3143 3144 3145 3146 3147 | * to skip the native filesystem --- since the tclFilename.c * code has nice fast 'absolute path' checkers, we don't want * to waste time repeating that effort here, and this * function is actually called quite often, so if we can * save the overhead of the native filesystem returning us * a list of volumes all the time, it is better. */ | | | 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 |
* to skip the native filesystem --- since the tclFilename.c
* code has nice fast 'absolute path' checkers, we don't want
* to waste time repeating that effort here, and this
* function is actually called quite often, so if we can
* save the overhead of the native filesystem returning us
* a list of volumes all the time, it is better.
*/
if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
int numVolumes;
Tcl_Obj *thisFsVolumes = (*proc)();
if (thisFsVolumes != NULL) {
if (Tcl_ListObjLength(NULL, thisFsVolumes,
&numVolumes) != TCL_OK) {
/*
* This is VERY bad; the Tcl_FSListVolumesProc
|
| ︙ | ︙ | |||
3199 3200 3201 3202 3203 3204 3205 |
}
FsReleaseIterator();
if (type != TCL_PATH_ABSOLUTE) {
type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
driveNameRef);
if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
| | | 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 |
}
FsReleaseIterator();
if (type != TCL_PATH_ABSOLUTE) {
type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
driveNameRef);
if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
*filesystemPtrPtr = &tclNativeFilesystem;
}
}
return type;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
if (proc != NULL) {
return (*proc)(pathPtr);
}
}
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCreateDirectory --
| > | 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
if (proc != NULL) {
return (*proc)(pathPtr);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCreateDirectory --
|
| ︙ | ︙ | |||
3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
if (proc != NULL) {
return (*proc)(pathPtr);
}
}
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCopyDirectory --
| > | 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 |
Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
if (proc != NULL) {
return (*proc)(pathPtr);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCopyDirectory --
|
| ︙ | ︙ | |||
3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 |
}
Tcl_DecrRefCount(cwdPtr);
}
}
return (*proc)(pathPtr, recursive, errorPtr);
}
}
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSConvertToPathType --
| > | 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 |
}
Tcl_DecrRefCount(cwdPtr);
}
}
return (*proc)(pathPtr, recursive, errorPtr);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSConvertToPathType --
|
| ︙ | ︙ | |||
3720 3721 3722 3723 3724 3725 3726 |
Tcl_Obj *transPtr;
char *name;
if (objPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
| < < < < < < < < < < < < < < < < < < | 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 |
Tcl_Obj *transPtr;
char *name;
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.
|
| ︙ | ︙ | |||
3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 |
Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = theFilesystemEpoch;
objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
objPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
/*
| > > > > > > | 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 |
Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = theFilesystemEpoch;
/*
* Free old representation before installing our new one.
*/
if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
(objPtr->typePtr->freeIntRepProc)(objPtr);
}
objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
objPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
3892 3893 3894 3895 3896 3897 3898 | * New memory may be allocated. * *--------------------------------------------------------------------------- */ Tcl_Obj * Tcl_FSNewNativePath(fromFilesystem, clientData) | | | > > > | > | < < | | 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 |
* New memory may be allocated.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSNewNativePath(fromFilesystem, clientData)
Tcl_Filesystem* fromFilesystem;
ClientData clientData;
{
Tcl_Obj *objPtr;
FsPath *fsPathPtr;
FilesystemRecord *fsFromPtr;
Tcl_FSInternalToNormalizedProc *proc;
int epoch;
fsFromPtr = GetFilesystemRecord(fromFilesystem, &epoch);
if (fsFromPtr == NULL) {
return NULL;
}
proc = fsFromPtr->fsPtr->internalToNormalizedProc;
if (proc == NULL) {
return NULL;
}
objPtr = (*proc)(clientData);
if (objPtr == NULL) {
|
| ︙ | ︙ | |||
3938 3939 3940 3941 3942 3943 3944 |
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
/* Circular reference, by design */
fsPathPtr->normPathPtr = objPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
| | | | 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 |
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;
/* We must increase the refCount for this filesystem. */
fsPathPtr->fsRecPtr->fileRefCount++;
fsPathPtr->filesystemEpoch = epoch;
objPtr->internalRep.otherValuePtr = (VOID *) fsPathPtr;
objPtr->typePtr = &tclFsPathType;
return objPtr;
}
static void
|
| ︙ | ︙ | |||
4339 4340 4341 4342 4343 4344 4345 | * * Side effects: * See Tcl_FSGetInternalRep. * *--------------------------------------------------------------------------- */ | | | | | 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 |
*
* Side effects:
* See Tcl_FSGetInternalRep.
*
*---------------------------------------------------------------------------
*/
CONST char *
Tcl_FSGetNativePath(pathObjPtr)
Tcl_Obj *pathObjPtr;
{
return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem);
}
/*
*---------------------------------------------------------------------------
*
* NativeCreateNativeRep --
*
|
| ︙ | ︙ | |||
4377 4378 4379 4380 4381 4382 4383 |
/* Make sure the normalized path is set */
normPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
str = Tcl_GetStringFromObj(normPtr,&len);
#ifdef __WIN32__
Tcl_WinUtfToTChar(str, len, &ds);
| > > > > > | | | > | | | 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 |
/* Make sure the normalized path is set */
normPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
str = Tcl_GetStringFromObj(normPtr,&len);
#ifdef __WIN32__
Tcl_WinUtfToTChar(str, len, &ds);
if (tclWinProcs->useWide) {
nativePathPtr = ckalloc((unsigned)(sizeof(WCHAR)+Tcl_DStringLength(&ds)));
memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds),
(size_t) (sizeof(WCHAR)+Tcl_DStringLength(&ds)));
} else {
nativePathPtr = ckalloc((unsigned)(sizeof(char)+Tcl_DStringLength(&ds)));
memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds),
(size_t) (sizeof(char)+Tcl_DStringLength(&ds)));
}
#else
Tcl_UtfToExternalDString(NULL, str, len, &ds);
nativePathPtr = ckalloc((unsigned)(sizeof(char)+Tcl_DStringLength(&ds)));
memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds),
(size_t) (sizeof(char)+Tcl_DStringLength(&ds)));
#endif
Tcl_DStringFree(&ds);
return (ClientData)nativePathPtr;
}
/*
|
| ︙ | ︙ | |||
4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 |
*/
Tcl_Obj*
TclpNativeToNormalized(clientData)
ClientData clientData;
{
Tcl_DString ds;
Tcl_Obj *objPtr;
#ifdef __WIN32__
Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
#else
Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
#endif
| > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
*/
Tcl_Obj*
TclpNativeToNormalized(clientData)
ClientData clientData;
{
Tcl_DString ds;
Tcl_Obj *objPtr;
CONST char *copy;
int len;
#ifdef __WIN32__
Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
#else
Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
#endif
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
#ifdef __WIN32__
/*
* Certain native path representations on Windows have this special
* prefix to indicate that they are to be treated specially. For
* example extremely long paths, or symlinks
*/
if (*copy == '\\') {
if (0 == strncmp(copy,"\\??\\",4)) {
copy += 4;
len -= 4;
} else if (0 == strncmp(copy,"\\\\?\\",4)) {
copy += 4;
len -= 4;
}
}
#endif
objPtr = Tcl_NewStringObj(copy,len);
Tcl_DStringFree(&ds);
return objPtr;
}
/*
|
| ︙ | ︙ | |||
4446 4447 4448 4449 4450 4451 4452 |
*
*---------------------------------------------------------------------------
*/
static ClientData
NativeDupInternalRep(clientData)
ClientData clientData;
{
| | | | < | > > > > > > > | < < < > > > > > > > | 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 |
*
*---------------------------------------------------------------------------
*/
static ClientData
NativeDupInternalRep(clientData)
ClientData clientData;
{
ClientData copy;
size_t len;
if (clientData == NULL) {
return NULL;
}
#ifdef __WIN32__
if (tclWinProcs->useWide) {
/* unicode representation when running on NT/2K/XP */
len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR));
} else {
/* ansi representation when running on 95/98/ME */
len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
}
#else
/* ansi representation when running on Unix/MacOS */
len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
#endif
copy = (ClientData) ckalloc(len);
memcpy((VOID*)copy, (VOID*)clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
* NativePathInFilesystem --
*
|
| ︙ | ︙ | |||
4662 4663 4664 4665 4666 4667 4668 |
Tcl_FSGetFileSystemForPath(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
FilesystemRecord *fsRecPtr;
Tcl_Filesystem* retVal = NULL;
FsPath* srcFsPathPtr;
| | > > > > > | | | > > > > > > > | 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 |
Tcl_FSGetFileSystemForPath(pathObjPtr)
Tcl_Obj* pathObjPtr;
{
FilesystemRecord *fsRecPtr;
Tcl_Filesystem* retVal = NULL;
FsPath* srcFsPathPtr;
/*
* 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) {
return NULL;
}
/*
* This will ensure the pathObjPtr 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.
*/
if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
return NULL;
}
/*
* Get a lock on theFilesystemEpoch and the filesystemList
*
|
| ︙ | ︙ | |||
4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 |
fsRecPtr = fsRecPtr->nextPtr;
}
done:
FsReleaseIterator();
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSEqualPaths --
*
* This function tests whether the two paths given are equal path
| > > > > > > > > > > > > > > > > > > | 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 |
fsRecPtr = fsRecPtr->nextPtr;
}
done:
FsReleaseIterator();
return retVal;
}
/* Simple helper function */
static FilesystemRecord*
GetFilesystemRecord(fromFilesystem, epoch)
Tcl_Filesystem *fromFilesystem;
int *epoch;
{
FilesystemRecord *fsRecPtr = FsGetIterator();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr == fromFilesystem) {
*epoch = theFilesystemEpoch;
break;
}
fsRecPtr = fsRecPtr->nextPtr;
}
FsReleaseIterator();
return fsRecPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSEqualPaths --
*
* This function tests whether the two paths given are equal path
|
| ︙ | ︙ |
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.34.2.3 2002/08/20 20:25:26 das Exp $ library tcl # Define the unsupported generic interfaces. interface tclInt |
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
declare 27 generic {
int TclGetDate(char *p, unsigned long now, long zone,
unsigned long *timePtr)
}
declare 28 generic {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
| > | | | < > > | | | < > | 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 |
declare 27 generic {
int TclGetDate(char *p, unsigned long now, long zone,
unsigned long *timePtr)
}
declare 28 generic {
Tcl_Channel TclpGetDefaultStdChannel(int type)
}
# Removed in 8.4b2:
#declare 29 generic {
# Tcl_Obj * TclGetElementOfIndexedArray(Tcl_Interp *interp,
# int localIndex, Tcl_Obj *elemPtr, int flags)
#}
# Replaced by char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr) in 8.1:
# declare 30 generic {
# char * TclGetEnv(CONST char *name)
# }
declare 31 generic {
char * TclGetExtension(char *name)
}
declare 32 generic {
int TclGetFrame(Tcl_Interp *interp, CONST char *str,
CallFrame **framePtrPtr)
}
declare 33 generic {
TclCmdProcType TclGetInterpProc(void)
}
declare 34 generic {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
# Removed in 8.4b2:
#declare 35 generic {
# Tcl_Obj * TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
# int flags)
#}
declare 36 generic {
int TclGetLong(Tcl_Interp *interp, CONST char *str, long *longPtr)
}
declare 37 generic {
int TclGetLoadedPackages(Tcl_Interp *interp, char *targetName)
}
declare 38 generic {
|
| ︙ | ︙ | |||
177 178 179 180 181 182 183 |
declare 41 generic {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 generic {
char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr)
}
declare 43 generic {
| | > | | | < > > | | | < > | | | | | 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 |
declare 41 generic {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 generic {
char * TclpGetUserHome(CONST char *name, Tcl_DString *bufferPtr)
}
declare 43 generic {
int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags)
}
declare 44 generic {
int TclGuessPackageName(CONST char *fileName, Tcl_DString *bufPtr)
}
declare 45 generic {
int TclHideUnsafeCommands(Tcl_Interp *interp)
}
declare 46 generic {
int TclInExit(void)
}
# Removed in 8.4b2:
#declare 47 generic {
# Tcl_Obj * TclIncrElementOfIndexedArray(Tcl_Interp *interp,
# int localIndex, Tcl_Obj *elemPtr, long incrAmount)
#}
# Removed in 8.4b2:
#declare 48 generic {
# Tcl_Obj * TclIncrIndexedScalar(Tcl_Interp *interp, int localIndex,
# long incrAmount)
#}
declare 49 generic {
Tcl_Obj * TclIncrVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, long incrAmount, int part1NotParsed)
}
declare 50 generic {
void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr,
Namespace *nsPtr)
}
declare 51 generic {
int TclInterpInit(Tcl_Interp *interp)
}
declare 52 generic {
int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, int flags)
}
declare 53 generic {
int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
int argc, CONST84 char **argv)
}
declare 54 generic {
int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[])
}
declare 55 generic {
Proc * TclIsProc(Command *cmdPtr)
}
# Replaced with TclpLoadFile in 8.1:
# declare 56 generic {
# int TclLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
# char *sym2, Tcl_PackageInitProc **proc1Ptr,
# Tcl_PackageInitProc **proc2Ptr)
# }
# Signature changed to take a length in 8.1:
# declare 57 generic {
# int TclLooksLikeInt(char *p)
# }
declare 58 generic {
Var * TclLookupVar(Tcl_Interp *interp, CONST char *part1, CONST char *part2,
int flags, CONST char *msg, int createPart1, int createPart2,
Var **arrayPtrPtr)
}
# Replaced by Tcl_FSMatchInDirectory in 8.4
#declare 59 generic {
# int TclpMatchFiles(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail)
#}
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 |
# int flags, char **termPtr, ParseValue *pvPtr)
# }
# declare 87 generic {
# void TclPlatformInit(Tcl_Interp *interp)
# }
declare 88 generic {
char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
| | | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
# int flags, char **termPtr, ParseValue *pvPtr)
# }
# declare 87 generic {
# void TclPlatformInit(Tcl_Interp *interp)
# }
declare 88 generic {
char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
CONST char *name1, CONST char *name2, int flags)
}
declare 89 generic {
int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
Tcl_Command cmd)
}
# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
# declare 90 generic {
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
CONST char *procName)
}
declare 93 generic {
void TclProcDeleteProc(ClientData clientData)
}
declare 94 generic {
int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp,
| | > | | | < > > | | | < > | 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 |
CONST char *procName)
}
declare 93 generic {
void TclProcDeleteProc(ClientData clientData)
}
declare 94 generic {
int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp,
int argc, CONST84 char **argv)
}
# Replaced by Tcl_FSStat in 8.4:
#declare 95 generic {
# int TclpStat(CONST char *path, Tcl_StatBuf *buf)
#}
declare 96 generic {
int TclRenameCommand(Tcl_Interp *interp, char *oldName, char *newName)
}
declare 97 generic {
void TclResetShadowedCmdRefs(Tcl_Interp *interp, Command *newCmdPtr)
}
declare 98 generic {
int TclServiceIdle(void)
}
# Removed in 8.4b2:
#declare 99 generic {
# Tcl_Obj * TclSetElementOfIndexedArray(Tcl_Interp *interp, int localIndex,
# Tcl_Obj *elemPtr, Tcl_Obj *objPtr, int flags)
#}
# Removed in 8.4b2:
#declare 100 generic {
# Tcl_Obj * TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
# Tcl_Obj *objPtr, int flags)
#}
declare 101 {unix win} {
char * TclSetPreInitScript(char *string)
}
declare 102 generic {
void TclSetupEnv(Tcl_Interp *interp)
}
declare 103 generic {
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
Tcl_ResolverInfo *resInfo)
}
declare 119 generic {
int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
declare 120 generic {
| | | 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 |
Tcl_ResolverInfo *resInfo)
}
declare 119 generic {
int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
declare 120 generic {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, CONST char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 generic {
int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
CONST char *pattern)
}
declare 122 generic {
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 |
# Added in 8.1:
#declare 137 generic {
# int TclpChdir(CONST char *dirName)
#}
declare 138 generic {
| | | | 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 |
# Added in 8.1:
#declare 137 generic {
# int TclpChdir(CONST char *dirName)
#}
declare 138 generic {
CONST84_RETURN char * TclGetEnv(CONST char *name, Tcl_DString *valuePtr)
}
#declare 139 generic {
# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
# char *sym2, Tcl_PackageInitProc **proc1Ptr,
# Tcl_PackageInitProc **proc2Ptr, ClientData *clientDataPtr)
#}
declare 140 generic {
int TclLooksLikeInt(CONST char *bytes, int length)
}
# This is used by TclX, but should otherwise be considered private
declare 141 generic {
CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 generic {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
CompileHookProc *hookProc, ClientData clientData)
}
declare 143 generic {
int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
|
| ︙ | ︙ | |||
604 605 606 607 608 609 610 |
#}
declare 156 generic {
void TclRegError (Tcl_Interp *interp, CONST char *msg,
int status)
}
declare 157 generic {
| | | | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
#}
declare 156 generic {
void TclRegError (Tcl_Interp *interp, CONST char *msg,
int status)
}
declare 157 generic {
Var * TclVarTraceExists (Tcl_Interp *interp, CONST char *varName)
}
declare 158 generic {
void TclSetStartupScriptFileName(CONST char *filename)
}
declare 159 generic {
CONST84_RETURN char *TclGetStartupScriptFileName(void)
}
#declare 160 generic {
# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail, GlobTypeData *types)
#}
# new in 8.3.2/8.4a2
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
declare 167 generic {
void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
declare 168 generic {
Tcl_Obj *TclGetStartupScriptPath(void)
}
| < > > > > | > > > > > | 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 |
# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above)
declare 167 generic {
void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
declare 168 generic {
Tcl_Obj *TclGetStartupScriptPath(void)
}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 generic {
int TclpUtfNcmp2(CONST char *s1, CONST char *s2, unsigned long n)
}
declare 170 generic {
int TclCheckInterpTraces (Tcl_Interp *interp, CONST char *command, int numChars, \
Command *cmdPtr, int result, int traceFlags, int objc, \
Tcl_Obj *CONST objv[])
}
declare 171 generic {
int TclCheckExecutionTraces (Tcl_Interp *interp, CONST char *command, int numChars, \
Command *cmdPtr, int result, int traceFlags, int objc, \
Tcl_Obj *CONST objv[])
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 942 |
}
# Added in 8.1:
declare 9 unix {
TclFile TclpCreateTempFile(CONST char *contents)
}
| > > > > > > > > > > > > > > > > > > | 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 |
}
# Added in 8.1:
declare 9 unix {
TclFile TclpCreateTempFile(CONST char *contents)
}
# Added in 8.4:
declare 10 unix {
Tcl_DirEntry * TclpReaddir(DIR * dir)
}
declare 11 unix {
struct tm * TclpLocaltime(time_t * clock)
}
declare 12 unix {
struct tm * TclpGmtime(time_t * 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.68.2.3 2002/08/20 20:25:26 das Exp $ */ #ifndef _TCLINT #define _TCLINT /* * Common include files needed by most of the Tcl source files are |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 |
Tcl_ResolveRuntimeVarProc *fetchProc;
Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
| | | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 |
Tcl_ResolveRuntimeVarProc *fetchProc;
Tcl_ResolveVarDeleteProc *deleteProc;
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc) _ANSI_ARGS_((
Tcl_Interp* interp, CONST84 char* name, int length,
Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr));
typedef int (Tcl_ResolveVarProc) _ANSI_ARGS_((
Tcl_Interp* interp, CONST84 char* name, Tcl_Namespace *context,
int flags, Tcl_Var *rPtr));
typedef int (Tcl_ResolveCmdProc) _ANSI_ARGS_((Tcl_Interp* interp,
CONST84 char* name, Tcl_Namespace *context, int flags,
Tcl_Command *rPtr));
typedef struct Tcl_ResolverInfo {
|
| ︙ | ︙ | |||
285 286 287 288 289 290 291 292 |
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr; /* Next in list of traces associated with
* a particular command. */
} CommandTrace;
typedef struct ActiveCommandTrace {
| > > > > > > > > | | | 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 |
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr; /* Next in list of traces associated with
* a particular command. */
} CommandTrace;
/*
* When a command trace is active (i.e. its associated procedure is
* executing), one of the following structures is linked into a list
* associated with the command's interpreter. The information in
* the structure is needed in order for Tcl to behave reasonably
* if traces are deleted while traces are active.
*/
typedef struct ActiveCommandTrace {
struct Command *cmdPtr; /* Command that's being traced. */
struct ActiveCommandTrace *nextPtr;
/* 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;
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details */
Tcl_CmdObjTraceDeleteProc* delProc;
/* Procedure to call when trace is deleted */
} Trace;
/*
* 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.
*/
| > > > > > > > > > > > > > > > > > > > | 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 |
struct Trace *nextPtr; /* Next in list of traces for this interp. */
int flags; /* Flags governing the trace - see
* Tcl_CreateObjTrace for details */
Tcl_CmdObjTraceDeleteProc* delProc;
/* Procedure to call when trace is deleted */
} Trace;
/*
* When an interpreter trace is active (i.e. its associated procedure
* is executing), one of the following structures is linked into a list
* associated with the interpreter. The information in the structure
* is needed in order for Tcl to behave reasonably if traces are
* deleted while traces are active.
*/
typedef struct ActiveInterpTrace {
struct ActiveInterpTrace *nextPtr;
/* 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.
*/
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 | * are a very lightweight method of preserving enough information * to determine if an arbitrary malloc'd block has been deleted. *---------------------------------------------------------------- */ typedef VOID **TclHandle; | < < < < < | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 | * are a very lightweight method of preserving enough information * to determine if an arbitrary malloc'd block has been deleted. *---------------------------------------------------------------- */ typedef VOID **TclHandle; /* *---------------------------------------------------------------- * Data structures related to history. These are used primarily * in tclHistory.c *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
typedef struct ExecEnv {
Tcl_Obj **stackPtr; /* Points to the first item in the
* evaluation stack on the heap. */
int stackTop; /* Index of current top of stack; -1 when
* the stack is empty. */
int stackEnd; /* Index of last usable item in stack. */
} ExecEnv;
/*
* The definitions for the LiteralTable and LiteralEntry structures. Each
* interpreter contains a LiteralTable. It is used to reduce the storage
* needed for all the Tcl objects that hold the literals of scripts compiled
* by the interpreter. A literal's object is shared by all the ByteCodes
| > > | 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 |
typedef struct ExecEnv {
Tcl_Obj **stackPtr; /* Points to the first item in the
* evaluation stack on the heap. */
int stackTop; /* Index of current top of stack; -1 when
* the stack is empty. */
int stackEnd; /* Index of last usable item in stack. */
Tcl_Obj *errorInfo;
Tcl_Obj *errorCode;
} ExecEnv;
/*
* The definitions for the LiteralTable and LiteralEntry structures. Each
* interpreter contains a LiteralTable. It is used to reduce the storage
* needed for all the Tcl objects that hold the literals of scripts compiled
* by the interpreter. A literal's object is shared by all the ByteCodes
|
| ︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 | * of being deleted (its deleteProc is * currently executing). Other attempts to * delete the command should be ignored. * CMD_TRACE_ACTIVE - 1 means that trace processing is currently * underway for a rename/delete change. * See the two flags below for which is * currently being processed. * TCL_TRACE_RENAME - A rename trace is in progress. Further * recursive renames will not be traced. * TCL_TRACE_DELETE - A delete trace is in progress. Further * recursive deletes will not be traced. * (these last two flags are defined in tcl.h) */ #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 /* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- */ | > > > > | 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 | * of being deleted (its deleteProc is * currently executing). Other attempts to * delete the command should be ignored. * CMD_TRACE_ACTIVE - 1 means that trace processing is currently * underway for a rename/delete change. * See the two flags below for which is * currently being processed. * CMD_HAS_EXEC_TRACES - 1 means that this command has at least * one execution trace (as opposed to simple * delete/rename traces) in its tracePtr list. * TCL_TRACE_RENAME - A rename trace is in progress. Further * recursive renames will not be traced. * TCL_TRACE_DELETE - A delete trace is in progress. Further * recursive deletes will not be traced. * (these last two flags are defined in tcl.h) */ #define CMD_IS_DELETED 0x1 #define CMD_TRACE_ACTIVE 0x2 #define CMD_HAS_EXEC_TRACES 0x4 /* *---------------------------------------------------------------- * Data structures related to name resolution procedures. *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1205 1206 1207 1208 1209 1210 1211 |
* procedure invocations. NULL means there
* are no active procedures. */
CallFrame *varFramePtr; /* Points to the call frame whose variables
* are currently in use (same as framePtr
* unless an "uplevel" command is
* executing). NULL means no procedure is
* active or "uplevel 0" is executing. */
| | | 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 |
* procedure invocations. NULL means there
* are no active procedures. */
CallFrame *varFramePtr; /* Points to the call frame whose variables
* are currently in use (same as framePtr
* unless an "uplevel" command is
* executing). NULL means no procedure is
* active or "uplevel 0" is executing. */
ActiveVarTrace *activeVarTracePtr;
/* First in list of active traces for
* interp, or NULL if no active traces. */
int returnCode; /* Completion code to return if current
* procedure exits with TCL_RETURN code. */
char *errorInfo; /* Value to store in errorInfo if returnCode
* is TCL_ERROR. Malloc'ed, may be NULL */
char *errorCode; /* Value to store in errorCode if returnCode
|
| ︙ | ︙ | |||
1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 |
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command 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.
| > > > | 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 |
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter */
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
* interp, or NULL if no active traces. */
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.
|
| ︙ | ︙ | |||
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 | * SAFE_INTERP: Non zero means that the current interp is a * safe interp (ie it has only the safe commands * installed, less priviledge than a regular interp). * USE_EVAL_DIRECT: Non-zero means don't use the compiler or byte-code * interpreter; instead, have Tcl_EvalObj call * Tcl_EvalEx. Used primarily for testing the * new parser. */ #define DELETED 1 #define ERR_IN_PROGRESS 2 #define ERR_ALREADY_LOGGED 4 #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 /* *---------------------------------------------------------------- * Data structures related to command parsing. These are used in * tclParse.c and its clients. *---------------------------------------------------------------- */ | > > > > | 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 | * SAFE_INTERP: Non zero means that the current interp is a * safe interp (ie it has only the safe commands * installed, less priviledge than a regular interp). * USE_EVAL_DIRECT: Non-zero means don't use the compiler or byte-code * interpreter; instead, have Tcl_EvalObj call * Tcl_EvalEx. Used primarily for testing the * new parser. * INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently * active; so no further trace callbacks should be * invoked. */ #define DELETED 1 #define ERR_IN_PROGRESS 2 #define ERR_ALREADY_LOGGED 4 #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 /* *---------------------------------------------------------------- * Data structures related to command parsing. These are used in * tclParse.c and its clients. *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 |
typedef struct TclFile_ *TclFile;
/*
* Opaque names for platform specific types.
*/
| | | 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 |
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
|
| ︙ | ︙ | |||
1555 1556 1557 1558 1559 1560 1561 | /* *---------------------------------------------------------------- * Data structures related to procedures *---------------------------------------------------------------- */ | | < | < | 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 | /* *---------------------------------------------------------------- * Data structures related to procedures *---------------------------------------------------------------- */ typedef Tcl_CmdProc *TclCmdProcType; typedef Tcl_ObjCmdProc *TclObjCmdProcType; /* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 | /* *---------------------------------------------------------------- * Procedures shared among Tcl modules but not used by the outside * world: *---------------------------------------------------------------- */ | < < < < < < < < < < < < < < < < < < < < < < < < | 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 | /* *---------------------------------------------------------------- * 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, |
| ︙ | ︙ | |||
1689 1690 1691 1692 1693 1694 1695 | EXTERN void TclFinalizeLoad _ANSI_ARGS_((void)); EXTERN void TclFinalizeMemorySubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeNotifier _ANSI_ARGS_((void)); EXTERN void TclFinalizeAsync _ANSI_ARGS_((void)); EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void)); EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void)); EXTERN void TclFindEncodings _ANSI_ARGS_((CONST char *argv0)); | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | EXTERN void TclFinalizeLoad _ANSI_ARGS_((void)); EXTERN void TclFinalizeMemorySubsystem _ANSI_ARGS_((void)); EXTERN void TclFinalizeNotifier _ANSI_ARGS_((void)); EXTERN void TclFinalizeAsync _ANSI_ARGS_((void)); EXTERN void TclFinalizeSynchronization _ANSI_ARGS_((void)); EXTERN void TclFinalizeThreadData _ANSI_ARGS_((void)); EXTERN void TclFindEncodings _ANSI_ARGS_((CONST char *argv0)); 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)); EXTERN void TclInitNamespaceSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitNotifier _ANSI_ARGS_((void)); EXTERN void TclInitObjSubsystem _ANSI_ARGS_((void)); EXTERN void TclInitSubsystems _ANSI_ARGS_((CONST char *argv0)); EXTERN int TclIsLocalScalar _ANSI_ARGS_((CONST char *src, int len)); EXTERN int TclJoinThread _ANSI_ARGS_((Tcl_ThreadId id, int* result)); EXTERN Tcl_Obj * TclLindexList _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* listPtr, Tcl_Obj* argPtr )); EXTERN Tcl_Obj * TclLindexFlat _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* listPtr, |
| ︙ | ︙ | |||
1774 1775 1776 1777 1778 1779 1780 | )); EXTERN Tcl_Obj * TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* listPtr, int indexCount, Tcl_Obj *CONST indexArray[], Tcl_Obj* valuePtr )); | | | | < | | | | | < < < < < < < < < < < < < < | 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 |
));
EXTERN Tcl_Obj * TclLsetFlat _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* listPtr,
int indexCount,
Tcl_Obj *CONST indexArray[],
Tcl_Obj* valuePtr
));
EXTERN int TclParseBackslash _ANSI_ARGS_((CONST char *src,
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 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));
EXTERN void 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,
|
| ︙ | ︙ | |||
1855 1856 1857 1858 1859 1860 1861 | 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)); | | > | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > | 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 |
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));
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 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));
EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
int result, Tcl_Interp *targetInterp));
EXTERN Tcl_Obj* TclpNativeToNormalized
_ANSI_ARGS_((ClientData clientData));
EXTERN Tcl_Obj* TclpFilesystemPathType
_ANSI_ARGS_((Tcl_Obj* pathObjPtr));
EXTERN Tcl_PackageInitProc* TclpFindSymbol _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_LoadHandle loadHandle, CONST char *symbol));
EXTERN int TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr,
Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr));
/*
*----------------------------------------------------------------
* Command procedures in the generic core:
*----------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
2092 2093 2094 2095 2096 2097 2098 | *---------------------------------------------------------------- * Command procedures found only in the Mac version of the core: *---------------------------------------------------------------- */ #ifdef MAC_TCL EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, | | | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 | *---------------------------------------------------------------- * Command procedures found only in the Mac version of the core: *---------------------------------------------------------------- */ #ifdef MAC_TCL EXTERN int Tcl_EchoCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv)); EXTERN int Tcl_LsObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_BeepObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_MacSourceObjCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); EXTERN int Tcl_ResourceObjCmd _ANSI_ARGS_((ClientData clientData, |
| ︙ | ︙ | |||
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 |
EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and release Tcl objects.
* TclNewObj(objPtr) creates a new object denoting an empty string.
* TclDecrRefCount(objPtr) decrements the object's reference count,
* and frees the object if its reference count is zero.
* These macros are inline versions of Tcl_NewObj() and
* Tcl_DecrRefCount(). Notice that the names differ in not having
* a "_" after the "Tcl". Notice also that these macros reference
* their argument more than once, so you should avoid calling them
* with an expression that is expensive to compute or has
* side effects. The ANSI C "prototypes" for these macros are:
*
* EXTERN void TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));
* EXTERN void TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
*----------------------------------------------------------------
*/
#ifdef TCL_COMPILE_STATS
# define TclIncrObjsAllocated() \
tclObjsAlloced++
# define TclIncrObjsFreed() \
tclObjsFreed++
#else
# define TclIncrObjsAllocated()
# define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | < < < < < | < < < | < | | < < < | > > > > > > > > > > > > > > > > > > > > | | < < < < < | < < < < < < < | < < < < | | < < < < | < < < < < < < < < | < | | | | | | | | < < < < < | | < < < < < < < < < | | | < | | | 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 |
EXTERN int TclCompileSetCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileStringCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
EXTERN int TclCompileWhileCmd _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
/*
* Functions defined in generic/tclVar.c and currenttly exported only
* for use by the bytecode compiler and engine. Some of these could later
* be placed in the public interface.
*/
EXTERN Var * TclLookupArrayElement _ANSI_ARGS_((Tcl_Interp *interp,
CONST char *arrayName, CONST char *elName, CONST int flags,
CONST char *msg, CONST int createPart1,
CONST int createPart2, Var *arrayPtr));
EXTERN Var * TclObjLookupVar _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *part1Ptr, CONST char *part2, int flags,
CONST char *msg, CONST int createPart1,
CONST int createPart2, Var **arrayPtrPtr));
EXTERN Tcl_Obj *TclPtrGetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, CONST char *part1, CONST char *part2,
CONST int flags));
EXTERN Tcl_Obj *TclPtrSetVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, CONST char *part1, CONST char *part2,
Tcl_Obj *newValuePtr, CONST int flags));
EXTERN Tcl_Obj *TclPtrIncrVar _ANSI_ARGS_((Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, CONST char *part1, CONST char *part2,
CONST long i, CONST int flags));
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and release Tcl objects.
* TclNewObj(objPtr) creates a new object denoting an empty string.
* TclDecrRefCount(objPtr) decrements the object's reference count,
* and frees the object if its reference count is zero.
* These macros are inline versions of Tcl_NewObj() and
* Tcl_DecrRefCount(). Notice that the names differ in not having
* a "_" after the "Tcl". Notice also that these macros reference
* their argument more than once, so you should avoid calling them
* with an expression that is expensive to compute or has
* side effects. The ANSI C "prototypes" for these macros are:
*
* EXTERN void TclNewObj _ANSI_ARGS_((Tcl_Obj *objPtr));
* EXTERN void TclDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
*
* These macros are defined in terms of two macros that depend on
* memory allocator in use: TclAllocObjStorage, TclFreeObjStorage.
* They are defined below.
*----------------------------------------------------------------
*/
#ifdef TCL_COMPILE_STATS
# define TclIncrObjsAllocated() \
tclObjsAlloced++
# define TclIncrObjsFreed() \
tclObjsFreed++
#else
# define TclIncrObjsAllocated()
# define TclIncrObjsFreed()
#endif /* TCL_COMPILE_STATS */
#define TclNewObj(objPtr) \
TclAllocObjStorage(objPtr); \
TclIncrObjsAllocated(); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL
#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(); \
}
#ifdef TCL_MEM_DEBUG
# define TclAllocObjStorage(objPtr) \
(objPtr) = (Tcl_Obj *) \
Tcl_DbCkalloc(sizeof(Tcl_Obj), __FILE__, __LINE__)
# define TclFreeObjStorage(objPtr) \
if ((objPtr)->refCount < -1) { \
panic("Reference count for %lx was negative: %s line %d", \
(objPtr), __FILE__, __LINE__); \
} \
ckfree((char *) (objPtr))
# define TclDbNewObj(objPtr, file, line) \
(objPtr) = (Tcl_Obj *) Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line)); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = tclEmptyStringRep; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TclIncrObjsAllocated()
#elif defined(PURIFY)
/*
* The PURIFY mode is like the regular mode, but instead of doing block
* Tcl_Obj allocation and keeping a freed list for efficiency, it always
* allocates and frees a single Tcl_Obj so that tools like Purify can
* better track memory leaks
*/
# define TclAllocObjStorage(objPtr) \
(objPtr) = (Tcl_Obj *) Tcl_Ckalloc(sizeof(Tcl_Obj))
# define TclFreeObjStorage(objPtr) \
ckfree((char *) (objPtr))
#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
/*
* 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))
#else /* not TCL_MEM_DEBUG */
#ifdef TCL_THREADS
/* declared in tclObj.c */
extern Tcl_Mutex tclObjMutex;
#endif
# define TclAllocObjStorage(objPtr) \
Tcl_MutexLock(&tclObjMutex); \
if (tclFreeObjList == NULL) { \
TclAllocateFreeObjects(); \
} \
(objPtr) = tclFreeObjList; \
tclFreeObjList = (Tcl_Obj *) \
tclFreeObjList->internalRep.otherValuePtr; \
Tcl_MutexUnlock(&tclObjMutex)
# define TclFreeObjStorage(objPtr) \
Tcl_MutexLock(&tclObjMutex); \
(objPtr)->internalRep.otherValuePtr = (VOID *) tclFreeObjList; \
tclFreeObjList = (objPtr); \
Tcl_MutexUnlock(&tclObjMutex)
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to set a Tcl_Obj's string representation
* to a copy of the "len" bytes starting at "bytePtr". This code
* works even if the byte array contains NULLs as long as the length
|
| ︙ | ︙ |
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.29.2.5 2002/08/20 20:25:26 das Exp $ */ #ifndef _TCLINTDECLS #define _TCLINTDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl |
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | TclAccessProc_ * proc)); /* 2 */ EXTERN int TclAccessInsertProc _ANSI_ARGS_(( TclAccessProc_ * proc)); /* 3 */ EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); /* Slot 4 is reserved */ | | | | 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 | TclAccessProc_ * proc)); /* 2 */ EXTERN int TclAccessInsertProc _ANSI_ARGS_(( TclAccessProc_ * proc)); /* 3 */ EXTERN void TclAllocateFreeObjects _ANSI_ARGS_((void)); /* Slot 4 is reserved */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 5 */ EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); #endif /* UNIX */ #ifdef __WIN32__ /* 5 */ EXTERN int TclCleanupChildren _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); #endif /* __WIN32__ */ /* 6 */ EXTERN void TclCleanupCommand _ANSI_ARGS_((Command * cmdPtr)); /* 7 */ EXTERN int TclCopyAndCollapse _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 8 */ EXTERN int TclCopyChannel _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 9 */ EXTERN int TclCreatePipeline _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); #endif /* UNIX */ #ifdef __WIN32__ |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr)); /* Slot 26 is reserved */ /* 27 */ EXTERN int TclGetDate _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * timePtr)); /* 28 */ EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type)); | | < < < | < < | 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 | EXTERN void TclFreePackageInfo _ANSI_ARGS_((Interp * iPtr)); /* Slot 26 is reserved */ /* 27 */ EXTERN int TclGetDate _ANSI_ARGS_((char * p, unsigned long now, long zone, unsigned long * 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 */ EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CallFrame ** framePtrPtr)); /* 33 */ EXTERN TclCmdProcType TclGetInterpProc _ANSI_ARGS_((void)); /* 34 */ EXTERN int TclGetIntForIndex _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* Slot 35 is reserved */ /* 36 */ EXTERN int TclGetLong _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * longPtr)); /* 37 */ EXTERN int TclGetLoadedPackages _ANSI_ARGS_(( Tcl_Interp * interp, char * targetName)); /* 38 */ |
| ︙ | ︙ | |||
161 162 163 164 165 166 167 | EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( Tcl_Command command)); /* 42 */ EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 43 */ EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp, | | | < < < | < < < | | | | | | 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 | EXTERN Tcl_Command TclGetOriginalCommand _ANSI_ARGS_(( Tcl_Command command)); /* 42 */ EXTERN char * TclpGetUserHome _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 43 */ EXTERN int TclGlobalInvoke _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 44 */ EXTERN int TclGuessPackageName _ANSI_ARGS_(( CONST char * fileName, Tcl_DString * bufPtr)); /* 45 */ EXTERN int TclHideUnsafeCommands _ANSI_ARGS_(( Tcl_Interp * interp)); /* 46 */ EXTERN int TclInExit _ANSI_ARGS_((void)); /* Slot 47 is reserved */ /* Slot 48 is reserved */ /* 49 */ EXTERN Tcl_Obj * TclIncrVar2 _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 50 */ EXTERN void TclInitCompiledLocals _ANSI_ARGS_(( Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 51 */ EXTERN int TclInterpInit _ANSI_ARGS_((Tcl_Interp * interp)); /* 52 */ EXTERN int TclInvoke _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 53 */ EXTERN int TclInvokeObjectCommand _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 54 */ EXTERN int TclInvokeStringCommand _ANSI_ARGS_(( ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 55 */ EXTERN Proc * TclIsProc _ANSI_ARGS_((Command * cmdPtr)); /* Slot 56 is reserved */ /* Slot 57 is reserved */ /* 58 */ EXTERN Var * TclLookupVar _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, CONST char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* Slot 59 is reserved */ /* 60 */ EXTERN int TclNeedSpace _ANSI_ARGS_((CONST char * start, CONST char * end)); /* 61 */ EXTERN Tcl_Obj * TclNewProcBodyObj _ANSI_ARGS_((Proc * procPtr)); /* 62 */ |
| ︙ | ︙ | |||
262 263 264 265 266 267 268 | /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* 88 */ EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, | | | > | < < < < | < < | | | 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 | /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* 88 */ EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, CONST char * name1, CONST char * name2, int flags)); /* 89 */ EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* Slot 90 is reserved */ /* 91 */ EXTERN void TclProcCleanupProc _ANSI_ARGS_((Proc * procPtr)); /* 92 */ EXTERN int TclProcCompileProc _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 93 */ EXTERN void TclProcDeleteProc _ANSI_ARGS_((ClientData clientData)); /* 94 */ EXTERN int TclProcInterpProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* Slot 95 is reserved */ /* 96 */ EXTERN int TclRenameCommand _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 97 */ EXTERN void TclResetShadowedCmdRefs _ANSI_ARGS_(( Tcl_Interp * interp, Command * newCmdPtr)); /* 98 */ EXTERN int TclServiceIdle _ANSI_ARGS_((void)); /* Slot 99 is reserved */ /* Slot 100 is reserved */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 101 */ EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string)); #endif /* UNIX */ #ifdef __WIN32__ /* 101 */ EXTERN char * TclSetPreInitScript _ANSI_ARGS_((char * string)); #endif /* __WIN32__ */ /* 102 */ EXTERN void TclSetupEnv _ANSI_ARGS_((Tcl_Interp * interp)); /* 103 */ EXTERN int TclSockGetPort _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 104 */ EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, int size)); #endif /* UNIX */ #ifdef __WIN32__ /* 104 */ EXTERN int TclSockMinimumBuffers _ANSI_ARGS_((int sock, |
| ︙ | ︙ | |||
369 370 371 372 373 374 375 | Tcl_ResolverInfo * resInfo)); /* 119 */ EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_(( Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 120 */ EXTERN Tcl_Var Tcl_FindNamespaceVar _ANSI_ARGS_(( | | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 | Tcl_ResolverInfo * resInfo)); /* 119 */ EXTERN int Tcl_GetNamespaceResolvers _ANSI_ARGS_(( Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 120 */ EXTERN Tcl_Var Tcl_FindNamespaceVar _ANSI_ARGS_(( Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 121 */ EXTERN int Tcl_ForgetImport _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern)); /* 122 */ EXTERN Tcl_Command Tcl_GetCommandFromObj _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr)); |
| ︙ | ︙ | |||
423 424 425 426 427 428 429 | CONST char * format, CONST struct tm * t, int useGMT)); /* 135 */ EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ | | | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 | CONST char * format, CONST struct tm * t, int useGMT)); /* 135 */ EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void)); /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ EXTERN CONST84_RETURN char * TclGetEnv _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* Slot 139 is reserved */ /* 140 */ EXTERN int TclLooksLikeInt _ANSI_ARGS_((CONST char * bytes, int length)); /* 141 */ EXTERN CONST84_RETURN char * TclpGetCwd _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 142 */ EXTERN int TclSetByteCodeFromAny _ANSI_ARGS_(( Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 143 */ |
| ︙ | ︙ | |||
471 472 473 474 475 476 477 | /* Slot 154 is reserved */ /* Slot 155 is reserved */ /* 156 */ EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp * interp, CONST char * msg, int status)); /* 157 */ EXTERN Var * TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp, | | | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 | /* Slot 154 is reserved */ /* Slot 155 is reserved */ /* 156 */ EXTERN void TclRegError _ANSI_ARGS_((Tcl_Interp * interp, CONST char * msg, int status)); /* 157 */ EXTERN Var * TclVarTraceExists _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 158 */ EXTERN void TclSetStartupScriptFileName _ANSI_ARGS_(( CONST char * filename)); /* 159 */ EXTERN CONST84_RETURN char * TclGetStartupScriptFileName _ANSI_ARGS_((void)); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 162 */ EXTERN void TclChannelEventScriptInvoker _ANSI_ARGS_(( ClientData clientData, int flags)); |
| ︙ | ︙ | |||
502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
EXTERN void TclSetStartupScriptPath _ANSI_ARGS_((
Tcl_Obj * pathPtr));
/* 168 */
EXTERN Tcl_Obj * TclGetStartupScriptPath _ANSI_ARGS_((void));
/* 169 */
EXTERN int TclpUtfNcmp2 _ANSI_ARGS_((CONST char * s1,
CONST char * s2, unsigned long n));
typedef struct TclIntStubs {
int magic;
struct TclIntStubHooks *hooks;
void *reserved0;
int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */
void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */
void *reserved4;
| > > > > > > > > > > > > | | | 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 |
EXTERN void TclSetStartupScriptPath _ANSI_ARGS_((
Tcl_Obj * pathPtr));
/* 168 */
EXTERN Tcl_Obj * TclGetStartupScriptPath _ANSI_ARGS_((void));
/* 169 */
EXTERN int TclpUtfNcmp2 _ANSI_ARGS_((CONST char * s1,
CONST char * s2, unsigned long n));
/* 170 */
EXTERN int TclCheckInterpTraces _ANSI_ARGS_((
Tcl_Interp * interp, CONST char * command,
int numChars, Command * cmdPtr, int result,
int traceFlags, int objc,
Tcl_Obj *CONST objv[]));
/* 171 */
EXTERN int TclCheckExecutionTraces _ANSI_ARGS_((
Tcl_Interp * interp, CONST char * command,
int numChars, Command * cmdPtr, int result,
int traceFlags, int objc,
Tcl_Obj *CONST objv[]));
typedef struct TclIntStubs {
int magic;
struct TclIntStubHooks *hooks;
void *reserved0;
int (*tclAccessDeleteProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 1 */
int (*tclAccessInsertProc) _ANSI_ARGS_((TclAccessProc_ * proc)); /* 2 */
void (*tclAllocateFreeObjects) _ANSI_ARGS_((void)); /* 3 */
void *reserved4;
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */
#endif /* UNIX */
#ifdef __WIN32__
int (*tclCleanupChildren) _ANSI_ARGS_((Tcl_Interp * interp, int numPids, Tcl_Pid * pidPtr, Tcl_Channel errorChan)); /* 5 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved5;
#endif /* MAC_TCL */
void (*tclCleanupCommand) _ANSI_ARGS_((Command * cmdPtr)); /* 6 */
int (*tclCopyAndCollapse) _ANSI_ARGS_((int count, CONST char * src, char * dst)); /* 7 */
int (*tclCopyChannel) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj * cmdPtr)); /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
int (*tclCreatePipeline) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST char ** argv, Tcl_Pid ** pidArrayPtr, TclFile * inPipePtr, TclFile * outPipePtr, TclFile * errFilePtr)); /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved9;
|
| ︙ | ︙ | |||
552 553 554 555 556 557 558 |
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, unsigned long now, long zone, unsigned long * timePtr)); /* 27 */
Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
| | | | | | | | | | 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 |
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, unsigned long now, long zone, unsigned long * 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 */
void *reserved35;
int (*tclGetLong) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, long * longPtr)); /* 36 */
int (*tclGetLoadedPackages) _ANSI_ARGS_((Tcl_Interp * interp, char * targetName)); /* 37 */
int (*tclGetNamespaceForQualName) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * qualName, Namespace * cxtNsPtr, int flags, Namespace ** nsPtrPtr, Namespace ** altNsPtrPtr, Namespace ** actualCxtPtrPtr, CONST char ** simpleNamePtr)); /* 38 */
TclObjCmdProcType (*tclGetObjInterpProc) _ANSI_ARGS_((void)); /* 39 */
int (*tclGetOpenMode) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, int * seekFlagPtr)); /* 40 */
Tcl_Command (*tclGetOriginalCommand) _ANSI_ARGS_((Tcl_Command command)); /* 41 */
char * (*tclpGetUserHome) _ANSI_ARGS_((CONST char * name, Tcl_DString * bufferPtr)); /* 42 */
int (*tclGlobalInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 43 */
int (*tclGuessPackageName) _ANSI_ARGS_((CONST char * fileName, Tcl_DString * bufPtr)); /* 44 */
int (*tclHideUnsafeCommands) _ANSI_ARGS_((Tcl_Interp * interp)); /* 45 */
int (*tclInExit) _ANSI_ARGS_((void)); /* 46 */
void *reserved47;
void *reserved48;
Tcl_Obj * (*tclIncrVar2) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * part1Ptr, Tcl_Obj * part2Ptr, long incrAmount, int part1NotParsed)); /* 49 */
void (*tclInitCompiledLocals) _ANSI_ARGS_((Tcl_Interp * interp, CallFrame * framePtr, Namespace * nsPtr)); /* 50 */
int (*tclInterpInit) _ANSI_ARGS_((Tcl_Interp * interp)); /* 51 */
int (*tclInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int argc, CONST84 char ** argv, int flags)); /* 52 */
int (*tclInvokeObjectCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 53 */
int (*tclInvokeStringCommand) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 54 */
Proc * (*tclIsProc) _ANSI_ARGS_((Command * cmdPtr)); /* 55 */
void *reserved56;
void *reserved57;
Var * (*tclLookupVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * part1, CONST char * part2, int flags, CONST char * msg, int createPart1, int createPart2, Var ** arrayPtrPtr)); /* 58 */
void *reserved59;
int (*tclNeedSpace) _ANSI_ARGS_((CONST char * start, CONST char * end)); /* 60 */
Tcl_Obj * (*tclNewProcBodyObj) _ANSI_ARGS_((Proc * procPtr)); /* 61 */
int (*tclObjCommandComplete) _ANSI_ARGS_((Tcl_Obj * cmdPtr)); /* 62 */
int (*tclObjInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[])); /* 63 */
int (*tclObjInvoke) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 64 */
int (*tclObjInvokeGlobal) _ANSI_ARGS_((Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags)); /* 65 */
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 |
char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */
void *reserved82;
void *reserved83;
void *reserved84;
void *reserved85;
void *reserved86;
void *reserved87;
| | | | | | | | 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 |
char * (*tclpRealloc) _ANSI_ARGS_((char * ptr, unsigned int size)); /* 81 */
void *reserved82;
void *reserved83;
void *reserved84;
void *reserved85;
void *reserved86;
void *reserved87;
char * (*tclPrecTraceProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, CONST char * name1, CONST char * name2, int flags)); /* 88 */
int (*tclPreventAliasLoop) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Interp * cmdInterp, Tcl_Command cmd)); /* 89 */
void *reserved90;
void (*tclProcCleanupProc) _ANSI_ARGS_((Proc * procPtr)); /* 91 */
int (*tclProcCompileProc) _ANSI_ARGS_((Tcl_Interp * interp, Proc * procPtr, Tcl_Obj * bodyPtr, Namespace * nsPtr, CONST char * description, CONST char * procName)); /* 92 */
void (*tclProcDeleteProc) _ANSI_ARGS_((ClientData clientData)); /* 93 */
int (*tclProcInterpProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp * interp, int argc, CONST84 char ** argv)); /* 94 */
void *reserved95;
int (*tclRenameCommand) _ANSI_ARGS_((Tcl_Interp * interp, char * oldName, char * newName)); /* 96 */
void (*tclResetShadowedCmdRefs) _ANSI_ARGS_((Tcl_Interp * interp, Command * newCmdPtr)); /* 97 */
int (*tclServiceIdle) _ANSI_ARGS_((void)); /* 98 */
void *reserved99;
void *reserved100;
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
#endif /* UNIX */
#ifdef __WIN32__
char * (*tclSetPreInitScript) _ANSI_ARGS_((char * string)); /* 101 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved101;
#endif /* MAC_TCL */
void (*tclSetupEnv) _ANSI_ARGS_((Tcl_Interp * interp)); /* 102 */
int (*tclSockGetPort) _ANSI_ARGS_((Tcl_Interp * interp, char * str, char * proto, int * portPtr)); /* 103 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */
#endif /* UNIX */
#ifdef __WIN32__
int (*tclSockMinimumBuffers) _ANSI_ARGS_((int sock, int size)); /* 104 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
void *reserved104;
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 |
Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
void (*tcl_DeleteNamespace) _ANSI_ARGS_((Tcl_Namespace * nsPtr)); /* 114 */
int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int resetListFirst)); /* 115 */
Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */
Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */
int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolverInfo * resInfo)); /* 118 */
int (*tcl_GetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 119 */
| | | | | | > > | 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 |
Tcl_Namespace * (*tcl_CreateNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, ClientData clientData, Tcl_NamespaceDeleteProc * deleteProc)); /* 113 */
void (*tcl_DeleteNamespace) _ANSI_ARGS_((Tcl_Namespace * nsPtr)); /* 114 */
int (*tcl_Export) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int resetListFirst)); /* 115 */
Tcl_Command (*tcl_FindCommand) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 116 */
Tcl_Namespace * (*tcl_FindNamespace) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 117 */
int (*tcl_GetInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_ResolverInfo * resInfo)); /* 118 */
int (*tcl_GetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolverInfo * resInfo)); /* 119 */
Tcl_Var (*tcl_FindNamespaceVar) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name, Tcl_Namespace * contextNsPtr, int flags)); /* 120 */
int (*tcl_ForgetImport) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern)); /* 121 */
Tcl_Command (*tcl_GetCommandFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 122 */
void (*tcl_GetCommandFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Command command, Tcl_Obj * objPtr)); /* 123 */
Tcl_Namespace * (*tcl_GetCurrentNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 124 */
Tcl_Namespace * (*tcl_GetGlobalNamespace) _ANSI_ARGS_((Tcl_Interp * interp)); /* 125 */
void (*tcl_GetVariableFullName) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Var variable, Tcl_Obj * objPtr)); /* 126 */
int (*tcl_Import) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Namespace * nsPtr, CONST char * pattern, int allowOverwrite)); /* 127 */
void (*tcl_PopCallFrame) _ANSI_ARGS_((Tcl_Interp* interp)); /* 128 */
int (*tcl_PushCallFrame) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_CallFrame * framePtr, Tcl_Namespace * nsPtr, int isProcCallFrame)); /* 129 */
int (*tcl_RemoveInterpResolvers) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * name)); /* 130 */
void (*tcl_SetNamespaceResolvers) _ANSI_ARGS_((Tcl_Namespace * namespacePtr, Tcl_ResolveCmdProc * cmdProc, Tcl_ResolveVarProc * varProc, Tcl_ResolveCompiledVarProc * compiledVarProc)); /* 131 */
int (*tclpHasSockets) _ANSI_ARGS_((Tcl_Interp * interp)); /* 132 */
struct tm * (*tclpGetDate) _ANSI_ARGS_((TclpTime_t time, int useGMT)); /* 133 */
size_t (*tclpStrftime) _ANSI_ARGS_((char * s, size_t maxsize, CONST char * format, CONST struct tm * t, int useGMT)); /* 134 */
int (*tclpCheckStackSpace) _ANSI_ARGS_((void)); /* 135 */
void *reserved136;
void *reserved137;
CONST84_RETURN char * (*tclGetEnv) _ANSI_ARGS_((CONST char * name, Tcl_DString * valuePtr)); /* 138 */
void *reserved139;
int (*tclLooksLikeInt) _ANSI_ARGS_((CONST char * bytes, int length)); /* 140 */
CONST84_RETURN char * (*tclpGetCwd) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_DString * cwdPtr)); /* 141 */
int (*tclSetByteCodeFromAny) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CompileHookProc * hookProc, ClientData clientData)); /* 142 */
int (*tclAddLiteralObj) _ANSI_ARGS_((struct CompileEnv * envPtr, Tcl_Obj * objPtr, LiteralEntry ** litPtrPtr)); /* 143 */
void (*tclHideLiteral) _ANSI_ARGS_((Tcl_Interp * interp, struct CompileEnv * envPtr, int index)); /* 144 */
struct AuxDataType * (*tclGetAuxDataType) _ANSI_ARGS_((char * typeName)); /* 145 */
TclHandle (*tclHandleCreate) _ANSI_ARGS_((VOID * ptr)); /* 146 */
void (*tclHandleFree) _ANSI_ARGS_((TclHandle handle)); /* 147 */
TclHandle (*tclHandlePreserve) _ANSI_ARGS_((TclHandle handle)); /* 148 */
void (*tclHandleRelease) _ANSI_ARGS_((TclHandle handle)); /* 149 */
int (*tclRegAbout) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_RegExp re)); /* 150 */
void (*tclRegExpRangeUniChar) _ANSI_ARGS_((Tcl_RegExp re, int index, int * startPtr, int * endPtr)); /* 151 */
void (*tclSetLibraryPath) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 152 */
Tcl_Obj * (*tclGetLibraryPath) _ANSI_ARGS_((void)); /* 153 */
void *reserved154;
void *reserved155;
void (*tclRegError) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * msg, int status)); /* 156 */
Var * (*tclVarTraceExists) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * varName)); /* 157 */
void (*tclSetStartupScriptFileName) _ANSI_ARGS_((CONST char * filename)); /* 158 */
CONST84_RETURN char * (*tclGetStartupScriptFileName) _ANSI_ARGS_((void)); /* 159 */
void *reserved160;
int (*tclChannelTransform) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan, Tcl_Obj * cmdObjPtr)); /* 161 */
void (*tclChannelEventScriptInvoker) _ANSI_ARGS_((ClientData clientData, int flags)); /* 162 */
void * (*tclGetInstructionTable) _ANSI_ARGS_((void)); /* 163 */
void (*tclExpandCodeArray) _ANSI_ARGS_((void * envPtr)); /* 164 */
void (*tclpSetInitialEncodings) _ANSI_ARGS_((void)); /* 165 */
int (*tclListObjSetElement) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * listPtr, int index, Tcl_Obj * valuePtr)); /* 166 */
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 */
} TclIntStubs;
#ifdef __cplusplus
extern "C" {
#endif
extern TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 | (tclIntStubsPtr->tclAccessInsertProc) /* 2 */ #endif #ifndef TclAllocateFreeObjects #define TclAllocateFreeObjects \ (tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */ #endif /* Slot 4 is reserved */ | | | 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 | (tclIntStubsPtr->tclAccessInsertProc) /* 2 */ #endif #ifndef TclAllocateFreeObjects #define TclAllocateFreeObjects \ (tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */ #endif /* Slot 4 is reserved */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef TclCleanupChildren #define TclCleanupChildren \ (tclIntStubsPtr->tclCleanupChildren) /* 5 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef TclCleanupChildren |
| ︙ | ︙ | |||
763 764 765 766 767 768 769 | #define TclCopyAndCollapse \ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ #endif #ifndef TclCopyChannel #define TclCopyChannel \ (tclIntStubsPtr->tclCopyChannel) /* 8 */ #endif | | | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 | #define TclCopyAndCollapse \ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ #endif #ifndef TclCopyChannel #define TclCopyChannel \ (tclIntStubsPtr->tclCopyChannel) /* 8 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef TclCreatePipeline #define TclCreatePipeline \ (tclIntStubsPtr->tclCreatePipeline) /* 9 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef TclCreatePipeline |
| ︙ | ︙ | |||
830 831 832 833 834 835 836 | #define TclGetDate \ (tclIntStubsPtr->tclGetDate) /* 27 */ #endif #ifndef TclpGetDefaultStdChannel #define TclpGetDefaultStdChannel \ (tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */ #endif | | < < < | < < < | 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 | #define TclGetDate \ (tclIntStubsPtr->tclGetDate) /* 27 */ #endif #ifndef TclpGetDefaultStdChannel #define TclpGetDefaultStdChannel \ (tclIntStubsPtr->tclpGetDefaultStdChannel) /* 28 */ #endif /* Slot 29 is reserved */ /* Slot 30 is reserved */ #ifndef TclGetExtension #define TclGetExtension \ (tclIntStubsPtr->tclGetExtension) /* 31 */ #endif #ifndef TclGetFrame #define TclGetFrame \ (tclIntStubsPtr->tclGetFrame) /* 32 */ #endif #ifndef TclGetInterpProc #define TclGetInterpProc \ (tclIntStubsPtr->tclGetInterpProc) /* 33 */ #endif #ifndef TclGetIntForIndex #define TclGetIntForIndex \ (tclIntStubsPtr->tclGetIntForIndex) /* 34 */ #endif /* Slot 35 is reserved */ #ifndef TclGetLong #define TclGetLong \ (tclIntStubsPtr->tclGetLong) /* 36 */ #endif #ifndef TclGetLoadedPackages #define TclGetLoadedPackages \ (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */ |
| ︙ | ︙ | |||
899 900 901 902 903 904 905 | #define TclHideUnsafeCommands \ (tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */ #endif #ifndef TclInExit #define TclInExit \ (tclIntStubsPtr->tclInExit) /* 46 */ #endif | | | < < < < < < | 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 | #define TclHideUnsafeCommands \ (tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */ #endif #ifndef TclInExit #define TclInExit \ (tclIntStubsPtr->tclInExit) /* 46 */ #endif /* Slot 47 is reserved */ /* Slot 48 is reserved */ #ifndef TclIncrVar2 #define TclIncrVar2 \ (tclIntStubsPtr->tclIncrVar2) /* 49 */ #endif #ifndef TclInitCompiledLocals #define TclInitCompiledLocals \ (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */ |
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 | #define TclResetShadowedCmdRefs \ (tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */ #endif #ifndef TclServiceIdle #define TclServiceIdle \ (tclIntStubsPtr->tclServiceIdle) /* 98 */ #endif | | < < < < < | < | | | 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 | #define TclResetShadowedCmdRefs \ (tclIntStubsPtr->tclResetShadowedCmdRefs) /* 97 */ #endif #ifndef TclServiceIdle #define TclServiceIdle \ (tclIntStubsPtr->tclServiceIdle) /* 98 */ #endif /* Slot 99 is reserved */ /* Slot 100 is reserved */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef TclSetPreInitScript #define TclSetPreInitScript \ (tclIntStubsPtr->tclSetPreInitScript) /* 101 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef TclSetPreInitScript #define TclSetPreInitScript \ (tclIntStubsPtr->tclSetPreInitScript) /* 101 */ #endif #endif /* __WIN32__ */ #ifndef TclSetupEnv #define TclSetupEnv \ (tclIntStubsPtr->tclSetupEnv) /* 102 */ #endif #ifndef TclSockGetPort #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ #endif #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef TclSockMinimumBuffers #define TclSockMinimumBuffers \ (tclIntStubsPtr->tclSockMinimumBuffers) /* 104 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef TclSockMinimumBuffers |
| ︙ | ︙ | |||
1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 | #define TclGetStartupScriptPath \ (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ #endif #ifndef TclpUtfNcmp2 #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ #endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ /* !END!: Do not edit above this line. */ #endif /* _TCLINTDECLS */ | > > > > > > > > | 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 | #define TclGetStartupScriptPath \ (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ #endif #ifndef TclpUtfNcmp2 #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ #endif #ifndef TclCheckInterpTraces #define TclCheckInterpTraces \ (tclIntStubsPtr->tclCheckInterpTraces) /* 170 */ #endif #ifndef TclCheckExecutionTraces #define TclCheckExecutionTraces \ (tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */ #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 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | /* * 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.12.6.4 2002/08/20 20:25:26 das Exp $ */ #ifndef _TCLINTPLATDECLS #define _TCLINTPLATDECLS /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the generic/tclInt.decls script. */ /* !BEGIN!: Do not edit below this line. */ /* * Exported function declarations: */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ /* 0 */ EXTERN void TclGetAndDetachPids _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 1 */ EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file)); /* 2 */ EXTERN Tcl_Channel TclpCreateCommandChannel _ANSI_ARGS_(( |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 62 63 64 65 66 67 68 | int mode)); /* 8 */ EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, int timeout)); /* 9 */ EXTERN TclFile TclpCreateTempFile _ANSI_ARGS_(( CONST char * contents)); #endif /* UNIX */ #ifdef __WIN32__ /* 0 */ EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode)); /* 1 */ EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode)); /* 2 */ | > > > > > > > > | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | int mode)); /* 8 */ EXTERN int TclUnixWaitForFile _ANSI_ARGS_((int fd, int mask, 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 _ANSI_ARGS_((time_t * clock)); /* 12 */ EXTERN struct tm * TclpGmtime _ANSI_ARGS_((time_t * clock)); /* 13 */ EXTERN char * TclpInetNtoa _ANSI_ARGS_((struct in_addr addr)); #endif /* UNIX */ #ifdef __WIN32__ /* 0 */ EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode)); /* 1 */ EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode)); /* 2 */ |
| ︙ | ︙ | |||
203 204 205 206 207 208 209 |
CONST char * path, FSSpecPtr theSpec));
#endif /* MAC_TCL */
typedef struct TclIntPlatStubs {
int magic;
struct TclIntPlatStubHooks *hooks;
| | > > > > | 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 |
CONST char * path, FSSpecPtr theSpec));
#endif /* MAC_TCL */
typedef struct TclIntPlatStubs {
int magic;
struct TclIntPlatStubHooks *hooks;
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
void (*tclGetAndDetachPids) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Channel chan)); /* 0 */
int (*tclpCloseFile) _ANSI_ARGS_((TclFile file)); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) _ANSI_ARGS_((TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid * pidPtr)); /* 2 */
int (*tclpCreatePipe) _ANSI_ARGS_((TclFile * readPipe, TclFile * writePipe)); /* 3 */
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) _ANSI_ARGS_((time_t * clock)); /* 11 */
struct tm * (*tclpGmtime) _ANSI_ARGS_((time_t * 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 */
HINSTANCE (*tclWinGetTclInstance) _ANSI_ARGS_((void)); /* 4 */
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 | #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) /* * Inline function declarations: */ | | | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 | #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) /* * Inline function declarations: */ #if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */ #ifndef TclGetAndDetachPids #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #endif #ifndef TclpCloseFile #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ |
| ︙ | ︙ | |||
328 329 330 331 332 333 334 335 336 337 338 339 340 341 | #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #endif #ifndef TclpCreateTempFile #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef TclWinConvertError #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #endif #ifndef TclWinConvertWSAError | > > > > > > > > > > > > > > > > | 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 | #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #endif #ifndef TclpCreateTempFile #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #endif #ifndef TclpReaddir #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #endif #ifndef TclpLocaltime #define TclpLocaltime \ (tclIntPlatStubsPtr->tclpLocaltime) /* 11 */ #endif #ifndef TclpGmtime #define TclpGmtime \ (tclIntPlatStubsPtr->tclpGmtime) /* 12 */ #endif #ifndef TclpInetNtoa #define TclpInetNtoa \ (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #endif #endif /* UNIX */ #ifdef __WIN32__ #ifndef TclWinConvertError #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #endif #ifndef TclWinConvertWSAError |
| ︙ | ︙ |
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.7.6.3 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #include <stdio.h> /* |
| ︙ | ︙ | |||
31 32 33 34 35 36 37 |
* when the source command is invoked.
*/
typedef struct Alias {
Tcl_Obj *namePtr; /* Name of alias command in slave interp. */
Tcl_Interp *targetInterp; /* Interp in which target command will be
* invoked. */
| < < < < < < > > > > > > > > > > | 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 |
* when the source command is invoked.
*/
typedef struct Alias {
Tcl_Obj *namePtr; /* Name of alias command in slave interp. */
Tcl_Interp *targetInterp; /* Interp in which target command will be
* invoked. */
Tcl_Command slaveCmd; /* Source command in slave interpreter,
* bound to command that invokes the target
* command in the target interpreter. */
Tcl_HashEntry *aliasEntryPtr;
/* Entry for the alias hash table in slave.
* This is used by alias deletion to remove
* the alias from the slave interpreter
* alias table. */
Tcl_HashEntry *targetEntryPtr;
/* Entry for target command in master.
* This is used in the master interpreter to
* map back from the target command to aliases
* redirecting to it. Random access to this
* hash table is never required - we are using
* a hash table only for convenience. */
int objc; /* Count of Tcl_Obj in the prefix of the
* target command to be invoked in the
* target interpreter. Additional arguments
* specified when calling the alias in the
* slave interp will be appended to the prefix
* before the command is invoked. */
Tcl_Obj *objPtr; /* The first actual prefix object - the target
* command name; this has to be at the end of the
* structure, which will be extended to accomodate
* the remaining objects in the prefix. */
} Alias;
/*
*
* struct Slave:
*
* Used by the "interp" command to record and find information about slave
|
| ︙ | ︙ | |||
827 828 829 830 831 832 833 |
int
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
CONST char *slaveCmd; /* Command to install in slave. */
Tcl_Interp *targetInterp; /* Interpreter for target command. */
CONST char *targetCmd; /* Name of target command. */
int argc; /* How many additional arguments? */
| | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
int
Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv)
Tcl_Interp *slaveInterp; /* Interpreter for source command. */
CONST char *slaveCmd; /* Command to install in slave. */
Tcl_Interp *targetInterp; /* Interpreter for target command. */
CONST char *targetCmd; /* Name of target command. */
int argc; /* How many additional arguments? */
CONST char * CONST *argv; /* These are the additional args. */
{
Tcl_Obj *slaveObjPtr, *targetObjPtr;
Tcl_Obj **objv;
int i;
int result;
objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
|
| ︙ | ︙ | |||
925 926 927 928 929 930 931 |
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
argvPtr)
Tcl_Interp *interp; /* Interp to start search from. */
CONST char *aliasName; /* Name of alias to find. */
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
CONST char **targetNamePtr; /* (Return) name of target command. */
int *argcPtr; /* (Return) count of addnl args. */
| | | > > | | 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 |
Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr,
argvPtr)
Tcl_Interp *interp; /* Interp to start search from. */
CONST char *aliasName; /* Name of alias to find. */
Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */
CONST char **targetNamePtr; /* (Return) name of target command. */
int *argcPtr; /* (Return) count of addnl args. */
CONST char ***argvPtr; /* (Return) additional arguments. */
{
InterpInfo *iiPtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
int i, objc;
Tcl_Obj **objv;
iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"alias \"", aliasName, "\" not found", (char *) NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
if (targetInterpPtr != NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != NULL) {
*targetNamePtr = Tcl_GetString(objv[0]);
}
if (argcPtr != NULL) {
*argcPtr = objc - 1;
}
if (argvPtr != NULL) {
*argvPtr = (CONST char **)
ckalloc((unsigned) sizeof(CONST char *) * (objc - 1));
for (i = 1; i < objc; i++) {
*argvPtr[i - 1] = Tcl_GetString(objv[i]);
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1001 1002 1003 1004 1005 1006 1007 |
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == (Tcl_HashEntry *) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"alias \"", aliasName, "\" not found", (char *) NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
| | > | 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 |
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == (Tcl_HashEntry *) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"alias \"", aliasName, "\" not found", (char *) NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
if (targetInterpPtr != (Tcl_Interp **) NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != (CONST char **) NULL) {
*targetNamePtr = Tcl_GetString(objv[0]);
}
|
| ︙ | ︙ | |||
1071 1072 1073 1074 1075 1076 1077 |
* If we encounter the alias we are defining (or renaming to) any in
* the chain then we have a loop.
*/
aliasPtr = (Alias *) cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
| < | | | | 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 |
* If we encounter the alias we are defining (or renaming to) any in
* the chain then we have a loop.
*/
aliasPtr = (Alias *) cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
Tcl_Obj *cmdNamePtr;
/*
* If the target of the next alias in the chain is the same as
* the source alias, we have a loop.
*/
cmdNamePtr = nextAliasPtr->objPtr;
aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp,
Tcl_GetString(cmdNamePtr),
Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp),
/*flags*/ 0);
if (aliasCmd == (Tcl_Command) NULL) {
return TCL_OK;
}
aliasCmdPtr = (Command *) aliasCmd;
if (aliasCmdPtr == cmdPtr) {
|
| ︙ | ︙ | |||
1147 1148 1149 1150 1151 1152 1153 1154 |
{
Alias *aliasPtr;
Tcl_HashEntry *hPtr;
int new;
Target *targetPtr;
Slave *slavePtr;
Master *masterPtr;
| > > | > | > > | > > > > | > > | > | 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 |
{
Alias *aliasPtr;
Tcl_HashEntry *hPtr;
int new;
Target *targetPtr;
Slave *slavePtr;
Master *masterPtr;
int i;
Tcl_Obj **prefv;
aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias)
+ objc * sizeof(Tcl_Obj *)));
aliasPtr->namePtr = namePtr;
Tcl_IncrRefCount(aliasPtr->namePtr);
aliasPtr->targetInterp = masterInterp;
aliasPtr->objc = objc + 1;
prefv = &aliasPtr->objPtr;
*prefv = targetNamePtr;
Tcl_IncrRefCount(targetNamePtr);
for (i = 0; i < objc; i++) {
*(++prefv) = objv[i];
Tcl_IncrRefCount(objv[i]);
}
aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp,
Tcl_GetString(namePtr), AliasObjCmd, (ClientData) aliasPtr,
AliasObjCmdDeleteProc);
if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) {
/*
* Found an alias loop! The last call to Tcl_CreateObjCommand made
* the alias point to itself. Delete the command and its alias
* record. Be careful to wipe out its client data first, so the
* command doesn't try to delete itself.
*/
Command *cmdPtr;
Tcl_DecrRefCount(aliasPtr->namePtr);
for (i = 0; i < objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
cmdPtr = (Command *) aliasPtr->slaveCmd;
cmdPtr->clientData = NULL;
cmdPtr->deleteProc = NULL;
cmdPtr->deleteData = NULL;
Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
|
| ︙ | ︙ | |||
1260 1261 1262 1263 1264 1265 1266 |
*----------------------------------------------------------------------
*/
static int
AliasDelete(interp, slaveInterp, namePtr)
Tcl_Interp *interp; /* Interpreter for result & errors. */
Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
| | | 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 |
*----------------------------------------------------------------------
*/
static int
AliasDelete(interp, slaveInterp, namePtr)
Tcl_Interp *interp; /* Interpreter for result & errors. */
Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
Tcl_Obj *namePtr; /* Name of alias to delete. */
{
Slave *slavePtr;
Alias *aliasPtr;
Tcl_HashEntry *hPtr;
/*
* If the alias has been renamed in the slave, the master can still use
|
| ︙ | ︙ | |||
1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
Tcl_Interp *interp; /* Interpreter for result & errors. */
Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
Tcl_Obj *namePtr; /* Name of alias to describe. */
{
Slave *slavePtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
/*
* If the alias has been renamed in the slave, the master can still use
* the original name (with which it was created) to find the alias to
* describe it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
if (hPtr == NULL) {
return TCL_OK;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
| > > | | 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 |
Tcl_Interp *interp; /* Interpreter for result & errors. */
Tcl_Interp *slaveInterp; /* Interpreter containing alias. */
Tcl_Obj *namePtr; /* Name of alias to describe. */
{
Slave *slavePtr;
Tcl_HashEntry *hPtr;
Alias *aliasPtr;
Tcl_Obj *prefixPtr;
/*
* If the alias has been renamed in the slave, the master can still use
* the original name (with which it was created) to find the alias to
* describe it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr));
if (hPtr == NULL) {
return TCL_OK;
}
aliasPtr = (Alias *) Tcl_GetHashValue(hPtr);
prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr);
Tcl_SetObjResult(interp, prefixPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AliasList --
|
| ︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
static int
AliasObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Alias record. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument vector. */
{
Tcl_Interp *targetInterp;
Alias *aliasPtr;
int result, prefc, cmdc;
| > < | < < < < < < < < < < < < < < < < < < < < | | | | < < | | < < < < > | < < < | < > > | < > | | < < | < < < < < > > | | > | | | | < < | < > | < > | 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 |
static int
AliasObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Alias record. */
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;
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
* in the target interp's global namespace.
*/
prefc = aliasPtr->objc;
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
cmdv = (Tcl_Obj **) ckalloc((unsigned) (cmdc * sizeof(Tcl_Obj *)));
}
prefv = &aliasPtr->objPtr;
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
}
/*
*----------------------------------------------------------------------
*
* AliasObjCmdDeleteProc --
*
|
| ︙ | ︙ | |||
1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 |
static void
AliasObjCmdDeleteProc(clientData)
ClientData clientData; /* The alias record for this alias. */
{
Alias *aliasPtr;
Target *targetPtr;
aliasPtr = (Alias *) clientData;
Tcl_DecrRefCount(aliasPtr->namePtr);
| > > > > | > | 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 |
static void
AliasObjCmdDeleteProc(clientData)
ClientData clientData; /* The alias record for this alias. */
{
Alias *aliasPtr;
Target *targetPtr;
int i;
Tcl_Obj **objv;
aliasPtr = (Alias *) clientData;
Tcl_DecrRefCount(aliasPtr->namePtr);
objv = &aliasPtr->objPtr;
for (i = 0; i < aliasPtr->objc; i++) {
Tcl_DecrRefCount(objv[i]);
}
Tcl_DeleteHashEntry(aliasPtr->aliasEntryPtr);
targetPtr = (Target *) Tcl_GetHashValue(aliasPtr->targetEntryPtr);
ckfree((char *) targetPtr);
Tcl_DeleteHashEntry(aliasPtr->targetEntryPtr);
ckfree((char *) aliasPtr);
|
| ︙ | ︙ |
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.3.28.3 2002/08/20 20:25:26 das 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 |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | #define LINK_BEING_UPDATED 2 /* * Forward references to procedures defined later in this file: */ static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData, | | | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
#define LINK_BEING_UPDATED 2
/*
* Forward references to procedures defined later in this file:
*/
static char * LinkTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr));
/*
*----------------------------------------------------------------------
*
* Tcl_LinkVar --
*
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
*
*----------------------------------------------------------------------
*/
int
Tcl_LinkVar(interp, varName, addr, type)
Tcl_Interp *interp; /* Interpreter in which varName exists. */
| | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
*
*----------------------------------------------------------------------
*/
int
Tcl_LinkVar(interp, varName, addr, type)
Tcl_Interp *interp; /* Interpreter in which varName exists. */
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;
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
*
*----------------------------------------------------------------------
*/
void
Tcl_UnlinkVar(interp, varName)
Tcl_Interp *interp; /* Interpreter containing variable to unlink. */
| | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
*
*----------------------------------------------------------------------
*/
void
Tcl_UnlinkVar(interp, varName)
Tcl_Interp *interp; /* Interpreter containing variable to unlink. */
CONST char *varName; /* Global variable in interp to unlink. */
{
Link *linkPtr;
linkPtr = (Link *) Tcl_VarTraceInfo(interp, varName, TCL_GLOBAL_ONLY,
LinkTraceProc, (ClientData) NULL);
if (linkPtr == NULL) {
return;
|
| ︙ | ︙ | |||
183 184 185 186 187 188 189 |
*
*----------------------------------------------------------------------
*/
void
Tcl_UpdateLinkedVar(interp, varName)
Tcl_Interp *interp; /* Interpreter containing variable. */
| | | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
*
*----------------------------------------------------------------------
*/
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) {
|
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
*----------------------------------------------------------------------
*/
static char *
LinkTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Contains information about the link. */
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
| | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
*----------------------------------------------------------------------
*/
static char *
LinkTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Contains information about the link. */
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
CONST char *name1; /* First part of variable name. */
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;
|
| ︙ | ︙ |
Changes to generic/tclLoad.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclLoad.c -- * * This file provides the generic portion (those that are the same * on all platforms) of Tcl's dynamic loading facilities. * * 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 | /* * tclLoad.c -- * * This file provides the generic portion (those that are the same * on all platforms) of Tcl's dynamic loading facilities. * * 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: tclLoad.c,v 1.6.8.2 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" /* * The following structure describes a package that has been loaded * either dynamically (with the "load" command) or statically (as |
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
* package was loaded. An empty string
* means the package is loaded statically.
* Malloc-ed. */
char *packageName; /* Name of package prefix for the package,
* properly capitalized (first letter UC,
* others LC), no "_", as in "Net".
* Malloc-ed. */
| | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
* package was loaded. An empty string
* means the package is loaded statically.
* Malloc-ed. */
char *packageName; /* Name of package prefix for the package,
* properly capitalized (first letter UC,
* others LC), no "_", as in "Net".
* Malloc-ed. */
Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be
* passed to (*unLoadProcPtr)() when the file
* is no longer needed. If fileName is NULL,
* then this field is irrelevant. */
Tcl_PackageInitProc *initProc;
/* Initialization procedure to call to
* incorporate this package into a trusted
* interpreter. */
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 |
Tcl_Interp *target;
LoadedPackage *pkgPtr, *defaultPtr;
Tcl_DString pkgName, tmp, initName, safeInitName;
Tcl_PackageInitProc *initProc, *safeInitProc;
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch;
char *p, *fullFileName, *packageName;
| | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
Tcl_Interp *target;
LoadedPackage *pkgPtr, *defaultPtr;
Tcl_DString pkgName, tmp, initName, safeInitName;
Tcl_PackageInitProc *initProc, *safeInitProc;
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch;
char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unLoadProcPtr = NULL;
Tcl_UniChar ch;
int offset;
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
336 337 338 339 340 341 342 | * Call platform-specific code to load the package and find the * two initialization procedures. */ Tcl_MutexLock(&packageMutex); code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName), Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc, | | | | | 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 |
* Call platform-specific code to load the package and find the
* two initialization procedures.
*/
Tcl_MutexLock(&packageMutex);
code = Tcl_FSLoadFile(interp, objv[1], Tcl_DStringValue(&initName),
Tcl_DStringValue(&safeInitName), &initProc, &safeInitProc,
&loadHandle,&unLoadProcPtr);
Tcl_MutexUnlock(&packageMutex);
if (code != TCL_OK) {
goto done;
}
if (initProc == NULL) {
Tcl_AppendResult(interp, "couldn't find procedure ",
Tcl_DStringValue(&initName), (char *) NULL);
if (unLoadProcPtr != NULL) {
(*unLoadProcPtr)(loadHandle);
}
code = TCL_ERROR;
goto done;
}
/*
* Create a new record to describe this package.
*/
pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
pkgPtr->fileName = (char *) ckalloc((unsigned)
(strlen(fullFileName) + 1));
strcpy(pkgPtr->fileName, fullFileName);
pkgPtr->packageName = (char *) ckalloc((unsigned)
(Tcl_DStringLength(&pkgName) + 1));
strcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName));
pkgPtr->loadHandle = loadHandle;
pkgPtr->unLoadProcPtr = unLoadProcPtr;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
pkgPtr->nextPtr = firstPackagePtr;
firstPackagePtr = pkgPtr;
Tcl_MutexUnlock(&packageMutex);
|
| ︙ | ︙ | |||
486 487 488 489 490 491 492 |
pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
pkgPtr->fileName[0] = 0;
pkgPtr->packageName = (char *) ckalloc((unsigned)
(strlen(pkgName) + 1));
strcpy(pkgPtr->packageName, pkgName);
| | | 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 |
pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
pkgPtr->fileName = (char *) ckalloc((unsigned) 1);
pkgPtr->fileName[0] = 0;
pkgPtr->packageName = (char *) ckalloc((unsigned)
(strlen(pkgName) + 1));
strcpy(pkgPtr->packageName, pkgName);
pkgPtr->loadHandle = NULL;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
pkgPtr->nextPtr = firstPackagePtr;
firstPackagePtr = pkgPtr;
Tcl_MutexUnlock(&packageMutex);
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 |
* atexit calls that can't be unregistered. If you unload
* such dlls, you get a core on exit because it wants to
* call a function in the dll after it's been unloaded.
*/
if (pkgPtr->fileName[0] != '\0') {
Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
if (unLoadProcPtr != NULL) {
| | | 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
* atexit calls that can't be unregistered. If you unload
* such dlls, you get a core on exit because it wants to
* call a function in the dll after it's been unloaded.
*/
if (pkgPtr->fileName[0] != '\0') {
Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr;
if (unLoadProcPtr != NULL) {
(*unLoadProcPtr)(pkgPtr->loadHandle);
}
}
#endif
ckfree(pkgPtr->fileName);
ckfree(pkgPtr->packageName);
ckfree((char *) pkgPtr);
}
}
|
Changes to generic/tclLoadNone.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclLoadNone.c -- * * This procedure provides a version of the TclLoadFile for use * in systems that don't support dynamic loading; it just returns * an error. * * 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 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 |
/*
* tclLoadNone.c --
*
* This procedure provides a version of the TclLoadFile for use
* in systems that don't support dynamic loading; it just returns
* an error.
*
* 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: tclLoadNone.c,v 1.6.2.2 2002/08/20 20:25:26 das Exp $
*/
#include "tclInt.h"
/*
*----------------------------------------------------------------------
*
* TclpDlopen --
*
* This procedure is called to carry out dynamic loading of binary
* code; it is intended for use only on systems that don't support
* dynamic loading (it returns an error).
*
* Results:
* The result is TCL_ERROR, and an error message is left in
* the interp's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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_SetResult(interp,
"dynamic loading is not currently available on this system",
TCL_STATIC);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* 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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
* If the "load" command is invoked without providing a package
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 | * Side effects: * None. * *---------------------------------------------------------------------- */ void | | | | | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
}
|
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.25.8.3 2002/08/20 20:25:26 das 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 |
| ︙ | ︙ | |||
2068 2069 2070 2071 2072 2073 2074 |
*----------------------------------------------------------------------
*/
Tcl_Var
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* variable. */
| | | 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 |
*----------------------------------------------------------------------
*/
Tcl_Var
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* variable. */
CONST char *name; /* Variable's name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
* Otherwise, points to namespace in which
* to resolve name. If NULL, look up name
|
| ︙ | ︙ |
Changes to generic/tclNotify.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * * Copyright (c) 1995-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. * | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * * Copyright (c) 1995-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: tclNotify.c,v 1.7.18.3 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclPort.h" extern TclStubs tclStubs; |
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
TclInitNotifier()
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_MutexLock(&listLock);
tsdPtr->threadId = Tcl_GetCurrentThread();
| < < < | < | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
TclInitNotifier()
{
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);
}
/*
|
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
}
tsdPtr->firstEventPtr = NULL;
tsdPtr->lastEventPtr = NULL;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
Tcl_MutexLock(&listLock);
| < < < | < < | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 |
}
tsdPtr->firstEventPtr = NULL;
tsdPtr->lastEventPtr = NULL;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
Tcl_MutexLock(&listLock);
tclStubs.tcl_FinalizeNotifier(tsdPtr->clientData);
Tcl_MutexFinalize(&(tsdPtr->queueMutex));
for (prevPtrPtr = &firstNotifierPtr; *prevPtrPtr != NULL;
prevPtrPtr = &((*prevPtrPtr)->nextPtr)) {
if (*prevPtrPtr == tsdPtr) {
*prevPtrPtr = tsdPtr->nextPtr;
break;
}
|
| ︙ | ︙ |
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.23.8.3 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclCompile.h" #include "tclPort.h" /* |
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
* 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.
*/
| | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
* 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.
*/
static Tcl_ObjType tclCmdNameType = {
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
(Tcl_UpdateStringProc *) NULL, /* updateStringProc */
SetCmdNameFromAny /* setFromAnyProc */
};
|
| ︙ | ︙ | |||
512 513 514 515 516 517 518 |
Tcl_Obj *
Tcl_NewObj()
{
register Tcl_Obj *objPtr;
/*
| | | < < < < < < < < < < | < < < < < < < | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
Tcl_Obj *
Tcl_NewObj()
{
register Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the
* correct allocator.
*/
TclNewObj(objPtr);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 |
* procedure; used for debugging. */
register int line; /* Line number in the source file; used
* for debugging. */
{
register Tcl_Obj *objPtr;
/*
| | | < | < < < < < < < < < < | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
* procedure; used for debugging. */
register int line; /* Line number in the source file; used
* for debugging. */
{
register Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the
* correct allocator.
*/
TclDbNewObj(objPtr, file, line);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewObj(file, line)
CONST char *file; /* The name of the source file calling this
* procedure; used for debugging. */
int line; /* Line number in the source file; used
|
| ︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 |
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get boolean. */
register int *boolPtr; /* Place to store resulting boolean. */
{
register int result;
| > > > | > > | 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
Tcl_GetBooleanFromObj(interp, objPtr, boolPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object from which to get boolean. */
register int *boolPtr; /* Place to store resulting boolean. */
{
register int result;
if (objPtr->typePtr == &tclBooleanType) {
result = TCL_OK;
} else {
result = SetBooleanFromAny(interp, objPtr);
}
if (result == TCL_OK) {
*boolPtr = (int) objPtr->internalRep.longValue;
}
return result;
}
/*
|
| ︙ | ︙ | |||
1110 1111 1112 1113 1114 1115 1116 |
char lowerCase[10];
int newBool, length;
register int i;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
| | > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | 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 |
char lowerCase[10];
int newBool, length;
register int i;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
string = Tcl_GetStringFromObj(objPtr, &length);
/*
* Use the obvious shortcuts for numerical values; if objPtr is not
* 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);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (objPtr->typePtr == &tclWideIntType) {
newBool = (objPtr->internalRep.wideValue != Tcl_LongAsWide(0));
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
/*
* Copy the string converting its characters to lower case.
*/
for (i = 0; (i < 9) && (i < length); i++) {
c = string[i];
/*
* Weed out international characters so we can safely operate
* on single bytes.
*/
if (c & 0x80) {
goto badBoolean;
}
if (Tcl_UniCharIsUpper(UCHAR(c))) {
c = (char) Tcl_UniCharToLower(UCHAR(c));
}
lowerCase[i] = c;
}
lowerCase[i] = 0;
/*
* Parse the string as a boolean. We use an implementation here that
* doesn't report errors in interp if interp is NULL.
*/
c = lowerCase[0];
if ((c == '0') && (lowerCase[1] == '\0')) {
newBool = 0;
} else if ((c == '1') && (lowerCase[1] == '\0')) {
newBool = 1;
} else if ((c == 'y') && (strncmp(lowerCase, "yes", (size_t) length) == 0)) {
newBool = 1;
} else if ((c == 'n') && (strncmp(lowerCase, "no", (size_t) length) == 0)) {
newBool = 0;
} else if ((c == 't') && (strncmp(lowerCase, "true", (size_t) length) == 0)) {
newBool = 1;
} else if ((c == 'f') && (strncmp(lowerCase, "false", (size_t) length) == 0)) {
newBool = 0;
} else if ((c == 'o') && (length >= 2)) {
if (strncmp(lowerCase, "on", (size_t) length) == 0) {
newBool = 1;
} else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
newBool = 0;
} else {
goto badBoolean;
}
} else {
double dbl;
/*
* Boolean values can be extracted from ints or doubles. Note
* that we don't use strtoul or strtoull here because we don't
* care about what the value is, just whether it is equal to
* zero or not.
*/
#ifdef TCL_WIDE_INT_IS_LONG
newBool = strtol(string, &end, 0);
if (end != string) {
/*
* Make sure the string has no garbage after the end of
* the int.
*/
while ((end < (string+length))
&& isspace(UCHAR(*end))) { /* INTL: ISO only */
end++;
}
if (end == (string+length)) {
newBool = (newBool != 0);
goto goodBoolean;
}
}
#else /* !TCL_WIDE_INT_IS_LONG */
Tcl_WideInt wide = strtoll(string, &end, 0);
if (end != string) {
/*
* Make sure the string has no garbage after the end of
* the wide int.
*/
while ((end < (string+length))
&& isspace(UCHAR(*end))) { /* INTL: ISO only */
end++;
}
if (end == (string+length)) {
newBool = (wide != Tcl_LongAsWide(0));
goto goodBoolean;
}
}
#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Still might be a string containing the characters representing an
* int or double that wasn't handled above. This would be a string
* like "27" or "1.0" that is non-zero and not "1". Such a string
* would result in the boolean value true. We try converting to
* double. If that succeeds and the resulting double is non-zero, we
* have a "true". Note that numbers can't have embedded NULLs.
*/
dbl = strtod(string, &end);
if (end == string) {
goto badBoolean;
}
/*
* Make sure the string has no garbage after the end of the double.
*/
while ((end < (string+length))
&& isspace(UCHAR(*end))) { /* INTL: ISO only */
end++;
}
if (end != (string+length)) {
goto badBoolean;
}
newBool = (dbl != 0.0);
}
}
/*
* 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.
*/
|
| ︙ | ︙ | |||
2848 2849 2850 2851 2852 2853 2854 |
Tcl_Command
Tcl_GetCommandFromObj(interp, objPtr)
Tcl_Interp *interp; /* The interpreter in which to resolve the
* command and to report errors. */
register Tcl_Obj *objPtr; /* The object containing the command's
* name. If the name starts with "::", will
* be looked up in global namespace. Else,
| | < | | 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 |
Tcl_Command
Tcl_GetCommandFromObj(interp, objPtr)
Tcl_Interp *interp; /* The interpreter in which to resolve the
* command and to report errors. */
register Tcl_Obj *objPtr; /* The object containing the command's
* name. If the name starts with "::", will
* be looked up in global namespace. Else,
* looked up first in the current namespace,
* then in global namespace. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
register Command *cmdPtr;
Namespace *currNsPtr;
int result;
CallFrame *savedFramePtr;
|
| ︙ | ︙ |
Changes to generic/tclParse.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclParse.c -- * * This file contains procedures that parse Tcl scripts. They * do so in a general-purpose fashion that can be used for many * different purposes, including compilation, direct execution, * code analysis, etc. * * Copyright (c) 1997 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 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 |
/*
* tclParse.c --
*
* This file contains procedures that parse Tcl scripts. They
* do so in a general-purpose fashion that can be used for many
* different purposes, including compilation, direct execution,
* code analysis, etc.
*
* 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.16.4.3 2002/08/20 20:25:26 das Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
/*
* The following table provides parsing information about each possible
* 8-bit character. The table is designed to be referenced with either
* signed or unsigned characters, so it has 384 entries. The first 128
* entries correspond to negative character values, the next 256 correspond
* to positive character values. The last 128 entries are identical to the
* first 128. The table is always indexed with a 128-byte offset (the 128th
* entry corresponds to a character value of 0).
*
* The macro CHAR_TYPE is used to index into the table and return
* information about its character argument. The following return
* values are defined.
*
* TYPE_NORMAL - All characters that don't have special significance
* to the Tcl parser.
* TYPE_SPACE - The character is a whitespace character other
* than newline.
* TYPE_COMMAND_END - Character is newline or semicolon.
* TYPE_SUBS - Character begins a substitution or has other
* special meaning in ParseTokens: backslash, dollar
* sign, or open bracket.
* TYPE_QUOTE - Character is a double quote.
* TYPE_CLOSE_PAREN - Character is a right parenthesis.
* TYPE_CLOSE_BRACK - Character is a right square bracket.
* TYPE_BRACE - Character is a curly brace (either left or right).
*/
#define TYPE_NORMAL 0
#define TYPE_SPACE 0x1
#define TYPE_COMMAND_END 0x2
#define TYPE_SUBS 0x4
#define TYPE_QUOTE 0x8
#define TYPE_CLOSE_PAREN 0x10
#define TYPE_CLOSE_BRACK 0x20
#define TYPE_BRACE 0x40
#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]
static CONST char charTypeTable[] = {
/*
* Negative character values, from -128 to -1:
*/
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
|
| ︙ | ︙ | |||
169 170 171 172 173 174 175 |
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local procedures defined in this file:
*/
| | | > > | | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 |
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local procedures defined in this file:
*/
static int CommandComplete _ANSI_ARGS_((CONST char *script,
int numBytes));
static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes,
Tcl_Parse *parsePtr));
static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes,
int mask, Tcl_Parse *parsePtr));
/*
*----------------------------------------------------------------------
*
* Tcl_ParseCommand --
*
* Given a string, this procedure parses the first Tcl command
* in the string and returns information about the structure of
|
| ︙ | ︙ | |||
205 206 207 208 209 210 211 |
*/
int
Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
| | | < < < < < | | | < | > | > > > | > | | | 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 |
*/
int
Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
CONST char *string; /* First character of string containing
* one or more Tcl commands. */
register int numBytes; /* Total number of bytes in string. If < 0,
* the script consists of all bytes up to
* the first null character. */
int nested; /* Non-zero means this is a nested command:
* close bracket should be considered
* a command terminator. If zero, then close
* bracket has no special meaning. */
register Tcl_Parse *parsePtr;
/* Structure to fill in with information
* about the parsed command; any previous
* information in the structure is
* ignored. */
{
register CONST char *src; /* Points to current character
* in the command. */
char type; /* Result returned by CHAR_TYPE(*src). */
Tcl_Token *tokenPtr; /* Pointer to token being filled in. */
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);
}
parsePtr->commentStart = NULL;
parsePtr->commentSize = 0;
parsePtr->commandStart = NULL;
parsePtr->commandSize = 0;
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
|
| ︙ | ︙ | |||
261 262 263 264 265 266 267 268 |
parsePtr->errorType = TCL_PARSE_SUCCESS;
if (nested != 0) {
terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
} else {
terminators = TYPE_COMMAND_END;
}
/*
| < < < < < < < < < < < < < < < < < < < < < < < | < < < | < < | < < < < < < < | | < < < < < < < < < < < < < < < < | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
parsePtr->errorType = TCL_PARSE_SUCCESS;
if (nested != 0) {
terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
} else {
terminators = TYPE_COMMAND_END;
}
/*
* Parse any leading space and comments before the first word of the
* command.
*/
scanned = ParseComment(string, numBytes, parsePtr);
src = (string + scanned); numBytes -= scanned;
if (numBytes == 0) {
if (nested) {
parsePtr->incomplete = nested;
}
}
/*
* The following loop parses the words of the command, one word
* in each iteration through the loop.
*/
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 | tokenPtr->type = TCL_TOKEN_WORD; /* * Skip white space before the word. Also skip a backslash-newline * sequence: it should be treated just like white space. */ | < < < < < < < | < < | | < < < < | | | | | | | | | 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 |
tokenPtr->type = TCL_TOKEN_WORD;
/*
* Skip white space before the word. Also skip a backslash-newline
* sequence: it should be treated just like white space.
*/
scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
src += scanned; numBytes -= scanned;
if (numBytes == 0) {
break;
}
if ((type & terminators) != 0) {
parsePtr->term = src;
src++;
break;
}
tokenPtr->start = src;
parsePtr->numTokens++;
parsePtr->numWords++;
/*
* At this point the word can have one of three forms: something
* enclosed in quotes, something enclosed in braces, or an
* unquoted word (anything else).
*/
if (*src == '"') {
if (Tcl_ParseQuotedString(interp, src, numBytes,
parsePtr, 1, &termPtr) != TCL_OK) {
goto error;
}
src = termPtr; numBytes = parsePtr->end - src;
} else if (*src == '{') {
if (Tcl_ParseBraces(interp, src, numBytes,
parsePtr, 1, &termPtr) != TCL_OK) {
goto error;
}
src = termPtr; numBytes = parsePtr->end - src;
} else {
/*
* This is an unquoted word. Call ParseTokens and let it do
* all of the work.
*/
if (ParseTokens(src, numBytes, TYPE_SPACE|terminators,
parsePtr) != TCL_OK) {
goto error;
}
src = parsePtr->term; numBytes = parsePtr->end - src;
}
/*
* Finish filling in the token for the word and check for the
* special case of a word consisting of a single range of
* literal text.
*/
|
| ︙ | ︙ | |||
427 428 429 430 431 432 433 | /* * Do two additional checks: (a) make sure we're really at the * end of a word (there might have been garbage left after a * quoted or braced word), and (b) check for the end of the * command. */ | < < < < < < < < < | < | < < < | | | | > > | | < < < < < < < < < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | > > | < | < < < < < | < | < < > | > | | > | > > > > > > > > > | > > > > < > < < < < < < < < < < | > > | > > > > > | | 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 |
/*
* Do two additional checks: (a) make sure we're really at the
* end of a word (there might have been garbage left after a
* quoted or braced word), and (b) check for the end of the
* command.
*/
scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
if (scanned) {
src += scanned; numBytes -= scanned;
continue;
}
if (numBytes == 0) {
break;
}
if ((type & terminators) != 0) {
parsePtr->term = src;
src++;
break;
}
if (src[-1] == '"') {
if (interp != NULL) {
Tcl_SetResult(interp, "extra characters after close-quote",
TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
} else {
if (interp != NULL) {
Tcl_SetResult(interp, "extra characters after close-brace",
TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
}
parsePtr->term = src;
goto error;
}
parsePtr->commandSize = src - parsePtr->commandStart;
return TCL_OK;
error:
Tcl_FreeParse(parsePtr);
if (parsePtr->commandStart == NULL) {
parsePtr->commandStart = string;
}
parsePtr->commandSize = parsePtr->term - parsePtr->commandStart;
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclParseWhiteSpace --
*
* Scans up to numBytes bytes starting at src, consuming white
* space as defined by Tcl's parsing rules.
*
* Results:
* Returns the number of bytes recognized as white space. Records
* at parsePtr, information about the parse. Records at typePtr
* the character type of the non-whitespace character that terminated
* the scan.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclParseWhiteSpace(src, numBytes, parsePtr, typePtr)
CONST char *src; /* First character to parse. */
register int numBytes; /* Max number of bytes to scan. */
Tcl_Parse *parsePtr; /* Information about parse in progress.
* Updated if parsing indicates
* an incomplete command. */
char *typePtr; /* Points to location to store character
* type of character that ends run
* of whitespace */
{
register char type = TYPE_NORMAL;
register CONST char *p = src;
while (1) {
while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
numBytes--; p++;
}
if (numBytes && (type & TYPE_SUBS)) {
if (*p != '\\') {
break;
}
if (--numBytes == 0) {
break;
}
if (p[1] != '\n') {
break;
}
p+=2;
if (--numBytes == 0) {
parsePtr->incomplete = 1;
break;
}
continue;
}
break;
}
*typePtr = type;
return (p - src);
}
/*
*----------------------------------------------------------------------
*
* TclParseHex --
*
* Scans a hexadecimal number as a Tcl_UniChar value.
* (e.g., for parsing \x and \u escape sequences).
* At most numBytes bytes are scanned.
*
* Results:
* The numeric value is stored in *resultPtr.
* Returns the number of bytes consumed.
*
* Notes:
* Relies on the following properties of the ASCII
* character set, with which UTF-8 is compatible:
*
* The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z'
* occupy consecutive code points, and '0' < 'A' < 'a'.
*
*----------------------------------------------------------------------
*/
int
TclParseHex(src, numBytes, resultPtr)
CONST char *src; /* First character to parse. */
int numBytes; /* Max number of byes to scan */
Tcl_UniChar *resultPtr; /* Points to storage provided by
* caller where the Tcl_UniChar
* resulting from the conversion is
* to be written. */
{
Tcl_UniChar result = 0;
register CONST char *p = src;
while (numBytes--) {
unsigned char digit = UCHAR(*p);
if (!isxdigit(digit))
break;
++p;
result <<= 4;
if (digit >= 'a') {
result |= (10 + digit - 'a');
} else if (digit >= 'A') {
result |= (10 + digit - 'A');
} else {
result |= (digit - '0');
}
}
*resultPtr = result;
return (p - src);
}
/*
*----------------------------------------------------------------------
*
* TclParseBackslash --
*
* Scans up to numBytes bytes starting at src, consuming a
* backslash sequence as defined by Tcl's parsing rules.
*
* Results:
* Records at readPtr the number of bytes making up the backslash
* sequence. Records at dst the UTF-8 encoded equivalent of
* that backslash sequence. Returns the number of bytes written
* to dst, at most TCL_UTF_MAX. Either readPtr or dst may be
* NULL, if the results are not needed, but the return value is
* the same either way.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclParseBackslash(src, numBytes, readPtr, dst)
CONST char * src; /* Points to the backslash character of a
* a backslash sequence */
int numBytes; /* Max number of bytes to scan */
int *readPtr; /* NULL, or points to storage where the
* number of bytes scanned should be written. */
char *dst; /* NULL, or points to buffer where the UTF-8
* encoding of the backslash sequence is to be
* written. At most TCL_UTF_MAX bytes will be
* written there. */
{
register CONST char *p = src+1;
Tcl_UniChar result;
int count;
char buf[TCL_UTF_MAX];
if (numBytes == 0) {
if (readPtr != NULL) {
*readPtr = 0;
}
return 0;
}
if (dst == NULL) {
dst = buf;
}
if (numBytes == 1) {
/* Can only scan the backslash. Return it. */
result = '\\';
count = 1;
goto done;
}
count = 2;
switch (*p) {
/*
* Note: in the conversions below, use absolute values (e.g.,
* 0xa) rather than symbolic values (e.g. \n) that get converted
* by the compiler. It's possible that compilers on some
* platforms will do the symbolic conversions differently, which
* could result in non-portable Tcl scripts.
*/
case 'a':
result = 0x7;
break;
case 'b':
result = 0x8;
break;
case 'f':
result = 0xc;
break;
case 'n':
result = 0xa;
break;
case 'r':
result = 0xd;
break;
case 't':
result = 0x9;
break;
case 'v':
result = 0xb;
break;
case 'x':
count += TclParseHex(p+1, numBytes-1, &result);
if (count == 2) {
/* No hexadigits -> This is just "x". */
result = 'x';
} else {
/* Keep only the last byte (2 hex digits) */
result = (unsigned char) result;
}
break;
case 'u':
count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result);
if (count == 2) {
/* No hexadigits -> This is just "u". */
result = 'u';
}
break;
case '\n':
count--;
do {
p++; count++;
} while ((count < numBytes) && ((*p == ' ') || (*p == '\t')));
result = ' ';
break;
case 0:
result = '\\';
count = 1;
break;
default:
/*
* Check for an octal number \oo?o?
*/
if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */
result = (unsigned char)(*p - '0');
p++;
if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */
|| (UCHAR(*p) >= '8')) {
break;
}
count = 3;
result = (unsigned char)((result << 3) + (*p - '0'));
p++;
if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */
|| (UCHAR(*p) >= '8')) {
break;
}
count = 4;
result = (unsigned char)((result << 3) + (*p - '0'));
break;
}
/*
* We have to convert here in case the user has put a
* backslash in front of a multi-byte utf-8 character.
* While this means nothing special, we shouldn't break up
* a correct utf-8 character. [Bug #217987] test subst-3.2
*/
if (Tcl_UtfCharComplete(p, numBytes - 1)) {
count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */
} else {
char utfBytes[TCL_UTF_MAX];
memcpy(utfBytes, p, (size_t) (numBytes - 1));
utfBytes[numBytes - 1] = '\0';
count = Tcl_UtfToUniChar(utfBytes, &result) + 1;
}
break;
}
done:
if (readPtr != NULL) {
*readPtr = count;
}
return Tcl_UniCharToUtf((int) result, dst);
}
/*
*----------------------------------------------------------------------
*
* ParseComment --
*
* Scans up to numBytes bytes starting at src, consuming a
* Tcl comment as defined by Tcl's parsing rules.
*
* Results:
* Records in parsePtr information about the parse. Returns the
* number of bytes consumed.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseComment(src, numBytes, parsePtr)
CONST char *src; /* First character to parse. */
register int numBytes; /* Max number of bytes to scan. */
Tcl_Parse *parsePtr; /* Information about parse in progress.
* Updated if parsing indicates
* an incomplete command. */
{
register CONST char *p = src;
while (numBytes) {
char type;
int scanned;
do {
scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
p += scanned; numBytes -= scanned;
} while (numBytes && (*p == '\n') && (p++,numBytes--));
if ((numBytes == 0) || (*p != '#')) {
break;
}
if (parsePtr->commentStart == NULL) {
parsePtr->commentStart = p;
}
while (numBytes) {
if (*p == '\\') {
scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type);
if (scanned) {
p += scanned; numBytes -= scanned;
} else {
/*
* General backslash substitution in comments isn't
* part of the formal spec, but test parse-15.47
* and history indicate that it has been the de facto
* rule. Don't change it now.
*/
TclParseBackslash(p, numBytes, &scanned, NULL);
p += scanned; numBytes -= scanned;
}
} else {
p++; numBytes--;
if (p[-1] == '\n') {
break;
}
}
}
parsePtr->commentSize = p - parsePtr->commentStart;
}
return (p - src);
}
/*
*----------------------------------------------------------------------
*
* ParseTokens --
*
* This procedure forms the heart of the Tcl parser. It parses one
* or more tokens from a string, up to a termination point
* specified by the caller. This procedure is used to parse
* unquoted command words (those not in quotes or braces), words in
* quotes, and array indices for variables. No more than numBytes
* bytes will be scanned.
*
* Results:
* Tokens are added to parsePtr and parsePtr->term is filled in
* with the address of the character that terminated the parse (the
* first one whose CHAR_TYPE matched mask or the character at
* parsePtr->end). The return value is TCL_OK if the parse
* completed successfully and TCL_ERROR otherwise. If a parse
* error occurs and parsePtr->interp isn't NULL, then an error
* message is left in the interpreter's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseTokens(src, numBytes, mask, parsePtr)
register CONST char *src; /* First character to parse. */
register int numBytes; /* Max number of bytes to scan. */
int mask; /* Specifies when to stop parsing. The
* parse stops at the first unquoted
* character whose CHAR_TYPE contains
* any of the bits in mask. */
Tcl_Parse *parsePtr; /* Information about parse in progress.
* Updated with additional tokens and
* termination information. */
{
char type;
int originalTokens, varToken;
Tcl_Token *tokenPtr;
Tcl_Parse nested;
/*
* Each iteration through the following loop adds one token of
* type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or
* TCL_TOKEN_VARIABLE to parsePtr. For TCL_TOKEN_VARIABLE tokens,
* additional tokens are added for the parsed variable name.
*/
originalTokens = parsePtr->numTokens;
while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) {
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->start = src;
tokenPtr->numComponents = 0;
if ((type & TYPE_SUBS) == 0) {
/*
* This is a simple range of characters. Scan to find the end
* of the range.
*/
while ((++src, --numBytes)
&& !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) {
/* empty loop */
}
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->size = src - tokenPtr->start;
parsePtr->numTokens++;
} else if (*src == '$') {
/*
* This is a variable reference. Call Tcl_ParseVarName to do
* all the dirty work of parsing the name.
*/
varToken = parsePtr->numTokens;
if (Tcl_ParseVarName(parsePtr->interp, src, numBytes,
parsePtr, 1) != TCL_OK) {
return TCL_ERROR;
}
src += parsePtr->tokenPtr[varToken].size;
numBytes -= parsePtr->tokenPtr[varToken].size;
} else if (*src == '[') {
/*
* Command substitution. Call Tcl_ParseCommand recursively
* (and repeatedly) to parse the nested command(s), then
* throw away the parse information.
*/
src++; numBytes--;
while (1) {
if (Tcl_ParseCommand(parsePtr->interp, src,
numBytes, 1, &nested) != TCL_OK) {
parsePtr->errorType = nested.errorType;
parsePtr->term = nested.term;
parsePtr->incomplete = nested.incomplete;
return TCL_ERROR;
}
src = nested.commandStart + nested.commandSize;
numBytes = parsePtr->end - src;
if (nested.tokenPtr != nested.staticTokens) {
ckfree((char *) nested.tokenPtr);
}
if ((*nested.term == ']') && !nested.incomplete) {
break;
}
if (numBytes == 0) {
if (parsePtr->interp != NULL) {
Tcl_SetResult(parsePtr->interp,
"missing close-bracket", TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
parsePtr->term = tokenPtr->start;
parsePtr->incomplete = 1;
return TCL_ERROR;
}
}
tokenPtr->type = TCL_TOKEN_COMMAND;
tokenPtr->size = src - tokenPtr->start;
parsePtr->numTokens++;
} else if (*src == '\\') {
/*
* Backslash substitution.
*/
TclParseBackslash(src, numBytes, &tokenPtr->size, NULL);
if (tokenPtr->size == 1) {
/* Just a backslash, due to end of string */
tokenPtr->type = TCL_TOKEN_TEXT;
parsePtr->numTokens++;
src++; numBytes--;
continue;
}
if (src[1] == '\n') {
if (numBytes == 2) {
parsePtr->incomplete = 1;
}
/*
* Note: backslash-newline is special in that it is
* treated the same as a space character would be. This
* means that it could terminate the token.
*/
if (mask & TYPE_SPACE) {
if (parsePtr->numTokens == originalTokens) {
goto finishToken;
}
break;
}
}
tokenPtr->type = TCL_TOKEN_BS;
parsePtr->numTokens++;
src += tokenPtr->size;
numBytes -= tokenPtr->size;
} else if (*src == 0) {
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->size = 1;
parsePtr->numTokens++;
src++; numBytes--;
} else {
panic("ParseTokens encountered unknown character");
}
}
if (parsePtr->numTokens == originalTokens) {
/*
* There was nothing in this range of text. Add an empty token
* for the empty range, so that there is always at least one
* token added.
*/
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->start = src;
tokenPtr->numComponents = 0;
finishToken:
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->size = 0;
parsePtr->numTokens++;
}
parsePtr->term = src;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FreeParse --
*
* This procedure is invoked to free any dynamic storage that may
* have been allocated by a previous call to Tcl_ParseCommand.
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 |
* previous call to Tcl_ParseCommand. */
{
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree((char *) parsePtr->tokenPtr);
parsePtr->tokenPtr = parsePtr->staticTokens;
}
}
| | | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
* previous call to Tcl_ParseCommand. */
{
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree((char *) parsePtr->tokenPtr);
parsePtr->tokenPtr = parsePtr->staticTokens;
}
}
/*
*----------------------------------------------------------------------
*
* TclExpandTokenArray --
*
* This procedure is invoked when the current space for tokens in
* a Tcl_Parse structure fills up; it allocates memory to grow the
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 |
(size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree((char *) parsePtr->tokenPtr);
}
parsePtr->tokenPtr = newPtr;
parsePtr->tokensAvailable = newCount;
}
| | | > | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 |
(size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree((char *) parsePtr->tokenPtr);
}
parsePtr->tokenPtr = newPtr;
parsePtr->tokensAvailable = newCount;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseVarName --
*
* Given a string starting with a $ sign, parse off a variable
* name and return information about the parse. No more than
* numBytes bytes will be scanned.
*
* Results:
* The return value is TCL_OK if the command was parsed
* successfully and TCL_ERROR otherwise. If an error occurs and
* interp isn't NULL then an error message is left in its result.
* On a successful return, tokenPtr and numTokens fields of
* parsePtr are filled in with information about the variable name
|
| ︙ | ︙ | |||
776 777 778 779 780 781 782 |
*/
int
Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
| | | | > > > | < < | | | 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 |
*/
int
Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
CONST char *string; /* String containing variable name. First
* character must be "$". */
register int numBytes; /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr; /* Structure to fill in with information
* about the variable name. */
int append; /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
* existing tokens in parsePtr and reinitialize
* it. */
{
Tcl_Token *tokenPtr;
register CONST char *src;
unsigned char c;
int varIndex, offset;
Tcl_UniChar ch;
unsigned array;
if ((numBytes == 0) || (string == NULL)) {
return TCL_ERROR;
}
if (numBytes < 0) {
numBytes = strlen(string);
}
if (!append) {
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->errorType = TCL_PARSE_SUCCESS;
parsePtr->incomplete = 0;
}
/*
* Generate one token for the variable, an additional token for the
|
| ︙ | ︙ | |||
829 830 831 832 833 834 835 |
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_VARIABLE;
tokenPtr->start = src;
varIndex = parsePtr->numTokens;
parsePtr->numTokens++;
tokenPtr++;
| | | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 |
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_VARIABLE;
tokenPtr->start = src;
varIndex = parsePtr->numTokens;
parsePtr->numTokens++;
tokenPtr++;
src++; numBytes--;
if (numBytes == 0) {
goto justADollarSign;
}
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src;
tokenPtr->numComponents = 0;
/*
|
| ︙ | ︙ | |||
855 856 857 858 859 860 861 |
* between parentheses is the array element name.
* 3. The $ sign is followed by something that isn't a letter,
* digit, or underscore: in this case, there is no variable
* name and the token is just "$".
*/
if (*src == '{') {
| | > | > > | | < | | | | | | < < < < < | > | > > > > > > | | | | | | | | | > | 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 |
* between parentheses is the array element name.
* 3. The $ sign is followed by something that isn't a letter,
* digit, or underscore: in this case, there is no variable
* name and the token is just "$".
*/
if (*src == '{') {
src++; numBytes--;
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src;
tokenPtr->numComponents = 0;
while (numBytes && (*src != '}')) {
numBytes--; src++;
}
if (numBytes == 0) {
if (interp != NULL) {
Tcl_SetResult(interp, "missing close-brace for variable name",
TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
parsePtr->term = tokenPtr->start-1;
parsePtr->incomplete = 1;
goto error;
}
tokenPtr->size = src - tokenPtr->start;
tokenPtr[-1].size = src - tokenPtr[-1].start;
parsePtr->numTokens++;
src++;
} else {
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src;
tokenPtr->numComponents = 0;
while (numBytes) {
if (Tcl_UtfCharComplete(src, numBytes)) {
offset = Tcl_UtfToUniChar(src, &ch);
} else {
char utfBytes[TCL_UTF_MAX];
memcpy(utfBytes, src, (size_t) numBytes);
utfBytes[numBytes] = '\0';
offset = Tcl_UtfToUniChar(utfBytes, &ch);
}
c = UCHAR(ch);
if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */
src += offset; numBytes -= offset;
continue;
}
if ((c == ':') && (numBytes != 1) && (src[1] == ':')) {
src += 2; numBytes -= 2;
while (numBytes && (*src == ':')) {
src++; numBytes--;
}
continue;
}
break;
}
/*
* Support for empty array names here.
*/
array = (numBytes && (*src == '('));
tokenPtr->size = src - tokenPtr->start;
if ((tokenPtr->size == 0) && !array) {
goto justADollarSign;
}
parsePtr->numTokens++;
if (array) {
/*
* This is a reference to an array element. Call
* ParseTokens recursively to parse the element name,
* since it could contain any number of substitutions.
*/
if (ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, parsePtr)
!= TCL_OK) {
goto error;
}
if ((parsePtr->term == (src + numBytes))
|| (*parsePtr->term != ')')) {
if (parsePtr->interp != NULL) {
Tcl_SetResult(parsePtr->interp, "missing )",
TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
parsePtr->term = src;
parsePtr->incomplete = 1;
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
tokenPtr->numComponents = 0;
return TCL_OK;
error:
Tcl_FreeParse(parsePtr);
return TCL_ERROR;
}
| | | 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 |
tokenPtr->numComponents = 0;
return TCL_OK;
error:
Tcl_FreeParse(parsePtr);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseVar --
*
* Given a string starting with a $ sign, parse off a variable
* name and return its value.
|
| ︙ | ︙ | |||
982 983 984 985 986 987 988 |
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_ParseVar(interp, string, termPtr)
Tcl_Interp *interp; /* Context for looking up variable. */
| | | | 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
*
*----------------------------------------------------------------------
*/
CONST char *
Tcl_ParseVar(interp, string, termPtr)
Tcl_Interp *interp; /* Context for looking up variable. */
register CONST char *string; /* String containing variable name.
* First character must be "$". */
CONST char **termPtr; /* If non-NULL, points to word to fill
* in with character just after last
* one in the variable specifier. */
{
Tcl_Parse parse;
register Tcl_Obj *objPtr;
int code;
|
| ︙ | ︙ | |||
1031 1032 1033 1034 1035 1036 1037 |
if (!Tcl_IsShared(objPtr)) {
Tcl_IncrRefCount(objPtr);
}
Tcl_ResetResult(interp);
return TclGetString(objPtr);
}
| | | > | 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 |
if (!Tcl_IsShared(objPtr)) {
Tcl_IncrRefCount(objPtr);
}
Tcl_ResetResult(interp);
return TclGetString(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseBraces --
*
* Given a string in braces such as a Tcl command argument or a string
* value in a Tcl expression, this procedure parses the string and
* returns information about the parse. No more than numBytes bytes
* will be scanned.
*
* Results:
* The return value is TCL_OK if the string was parsed successfully and
* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
* an error message is left in its result. On a successful return,
* tokenPtr and numTokens fields of parsePtr are filled in with
* information about the string that was parsed. Other fields in
|
| ︙ | ︙ | |||
1065 1066 1067 1068 1069 1070 1071 |
*/
int
Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
| | | | < | | > > | < | | | | | > | > > > > > | > > > > > > > > > | | > | > > > > > > > > > > > > > > > > > > > > | > > | | > | > > > > | > | > > > | > > > > > > > > > > > > | > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | < < < | < < | < < < < < < < < < < < < | < < < < < < < < < | < < | < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | 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 |
*/
int
Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
CONST char *string; /* String containing the string in braces.
* The first character must be '{'. */
register int numBytes; /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to
* the first null character. */
register Tcl_Parse *parsePtr;
/* Structure to fill in with information
* about the string. */
int append; /* Non-zero means append tokens to existing
* information in parsePtr; zero means
* ignore existing tokens in parsePtr and
* reinitialize it. */
CONST char **termPtr; /* If non-NULL, points to word in which to
* store a pointer to the character just
* after the terminating '}' if the parse
* was successful. */
{
Tcl_Token *tokenPtr;
register CONST char *src;
int startIndex, level, length;
if ((numBytes == 0) || (string == NULL)) {
return TCL_ERROR;
}
if (numBytes < 0) {
numBytes = strlen(string);
}
if (!append) {
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->errorType = TCL_PARSE_SUCCESS;
}
src = string;
startIndex = parsePtr->numTokens;
if (parsePtr->numTokens == parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[startIndex];
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src+1;
tokenPtr->numComponents = 0;
level = 1;
while (1) {
while (++src, --numBytes) {
if (CHAR_TYPE(*src) != TYPE_NORMAL) {
break;
}
}
if (numBytes == 0) {
register int openBrace = 0;
parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
parsePtr->term = string;
parsePtr->incomplete = 1;
if (interp == NULL) {
/*
* Skip straight to the exit code since we have no
* interpreter to put error message in.
*/
goto error;
}
Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
/*
* Guess if the problem is due to comments by searching
* the source string for a possible open brace within the
* context of a comment. Since we aren't performing a
* full Tcl parse, just look for an open brace preceded
* by a '<whitespace>#' on the same line.
*/
for (; src > string; src--) {
switch (*src) {
case '{':
openBrace = 1;
break;
case '\n':
openBrace = 0;
break;
case '#' :
if (openBrace && (isspace(UCHAR(src[-1])))) {
Tcl_AppendResult(interp,
": possible unbalanced brace in comment",
(char *) NULL);
goto error;
}
break;
}
}
error:
Tcl_FreeParse(parsePtr);
return TCL_ERROR;
}
switch (*src) {
case '{':
level++;
break;
case '}':
if (--level == 0) {
/*
* Decide if we need to finish emitting a
* partially-finished token. There are 3 cases:
* {abc \newline xyz} or {xyz}
* - finish emitting "xyz" token
* {abc \newline}
* - don't emit token after \newline
* {} - finish emitting zero-sized token
*
* The last case ensures that there is a token
* (even if empty) that describes the braced string.
*/
if ((src != tokenPtr->start)
|| (parsePtr->numTokens == startIndex)) {
tokenPtr->size = (src - tokenPtr->start);
parsePtr->numTokens++;
}
if (termPtr != NULL) {
*termPtr = src+1;
}
return TCL_OK;
}
break;
case '\\':
TclParseBackslash(src, numBytes, &length, NULL);
if ((length > 1) && (src[1] == '\n')) {
/*
* A backslash-newline sequence must be collapsed, even
* inside braces, so we have to split the word into
* multiple tokens so that the backslash-newline can be
* represented explicitly.
*/
if (numBytes == 2) {
parsePtr->incomplete = 1;
}
tokenPtr->size = (src - tokenPtr->start);
if (tokenPtr->size != 0) {
parsePtr->numTokens++;
}
if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
TclExpandTokenArray(parsePtr);
}
tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
tokenPtr->type = TCL_TOKEN_BS;
tokenPtr->start = src;
tokenPtr->size = length;
tokenPtr->numComponents = 0;
parsePtr->numTokens++;
src += length - 1;
numBytes -= length - 1;
tokenPtr++;
tokenPtr->type = TCL_TOKEN_TEXT;
tokenPtr->start = src + 1;
tokenPtr->numComponents = 0;
} else {
src += length - 1;
numBytes -= length - 1;
}
break;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseQuotedString --
*
* Given a double-quoted string such as a quoted Tcl command argument
* or a quoted value in a Tcl expression, this procedure parses the
* string and returns information about the parse. No more than
* numBytes bytes will be scanned.
*
* Results:
* The return value is TCL_OK if the string was parsed successfully and
* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
* an error message is left in its result. On a successful return,
* tokenPtr and numTokens fields of parsePtr are filled in with
* information about the string that was parsed. Other fields in
|
| ︙ | ︙ | |||
1270 1271 1272 1273 1274 1275 1276 |
*/
int
Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
| | | | | > | < | < | | | | | | 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 |
*/
int
Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting;
* if NULL, then no error message is
* provided. */
CONST char *string; /* String containing the quoted string.
* The first character must be '"'. */
register int numBytes; /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to
* the first null character. */
register Tcl_Parse *parsePtr;
/* Structure to fill in with information
* about the string. */
int append; /* Non-zero means append tokens to existing
* information in parsePtr; zero means
* ignore existing tokens in parsePtr and
* reinitialize it. */
CONST char **termPtr; /* If non-NULL, points to word in which to
* store a pointer to the character just
* after the quoted string's terminating
* close-quote if the parse succeeds. */
{
if ((numBytes == 0) || (string == NULL)) {
return TCL_ERROR;
}
if (numBytes < 0) {
numBytes = strlen(string);
}
if (!append) {
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->errorType = TCL_PARSE_SUCCESS;
}
if (ParseTokens(string+1, numBytes-1, TYPE_QUOTE, parsePtr) != TCL_OK) {
goto error;
}
if (*parsePtr->term != '"') {
if (interp != NULL) {
Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
}
parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
parsePtr->term = string;
parsePtr->incomplete = 1;
goto error;
}
if (termPtr != NULL) {
*termPtr = (parsePtr->term + 1);
}
return TCL_OK;
error:
Tcl_FreeParse(parsePtr);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* CommandComplete --
*
* This procedure is shared by TclCommandComplete and
* Tcl_ObjCommandcoComplete; it does all the real work of seeing
|
| ︙ | ︙ | |||
1349 1350 1351 1352 1353 1354 1355 | * Side effects: * None. * *---------------------------------------------------------------------- */ static int | | | | | | | | 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 |
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
CommandComplete(script, numBytes)
CONST char *script; /* Script to check. */
int numBytes; /* Number of bytes in script. */
{
Tcl_Parse parse;
CONST char *p, *end;
int result;
p = script;
end = p + numBytes;
while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse)
== TCL_OK) {
p = parse.commandStart + parse.commandSize;
if (*p == 0) {
break;
}
Tcl_FreeParse(&parse);
}
if (parse.incomplete) {
result = 0;
} else {
result = 1;
}
Tcl_FreeParse(&parse);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CommandComplete --
*
* Given a partial or complete Tcl script, this procedure
* determines whether the script is complete in the sense
|
| ︙ | ︙ | |||
1398 1399 1400 1401 1402 1403 1404 | * None. * *---------------------------------------------------------------------- */ int Tcl_CommandComplete(script) | | | | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 |
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_CommandComplete(script)
CONST char *script; /* Script to check. */
{
return CommandComplete(script, (int) strlen(script));
}
/*
*----------------------------------------------------------------------
*
* TclObjCommandComplete --
*
* Given a partial or complete Tcl command in a Tcl object, this
* procedure determines whether the command is complete in the sense of
|
| ︙ | ︙ | |||
1426 1427 1428 1429 1430 1431 1432 |
*/
int
TclObjCommandComplete(objPtr)
Tcl_Obj *objPtr; /* Points to object holding script
* to check. */
{
| | | | 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 |
*/
int
TclObjCommandComplete(objPtr)
Tcl_Obj *objPtr; /* Points to object holding script
* to check. */
{
CONST char *script;
int length;
script = Tcl_GetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
/*
*----------------------------------------------------------------------
*
* TclIsLocalScalar --
*
* Check to see if a given string is a legal scalar variable
* name with no namespace qualifiers or substitutions.
|
| ︙ | ︙ |
Changes to generic/tclParseExpr.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * tclParseExpr.c -- * * This file contains procedures that parse Tcl expressions. They * do so in a general-purpose fashion that can be used for many * different purposes, including compilation, direct execution, * code analysis, etc. * * 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 22 23 | /* * tclParseExpr.c -- * * This file contains procedures that parse Tcl expressions. They * do so in a general-purpose fashion that can be used for many * different purposes, including compilation, direct execution, * code analysis, etc. * * 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.9.2.3 2002/08/20 20:25:26 das 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 |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
typedef struct ParseInfo {
Tcl_Parse *parsePtr; /* Points to structure to fill in with
* information about the expression. */
int lexeme; /* Type of last lexeme scanned in expr.
* See below for definitions. Corresponds to
* size characters beginning at start. */
| | | | | | | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
typedef struct ParseInfo {
Tcl_Parse *parsePtr; /* Points to structure to fill in with
* information about the expression. */
int lexeme; /* Type of last lexeme scanned in expr.
* See below for definitions. Corresponds to
* size characters beginning at start. */
CONST char *start; /* First character in lexeme. */
int size; /* Number of bytes in lexeme. */
CONST char *next; /* Position of the next character to be
* scanned in the expression string. */
CONST char *prevEnd; /* Points to the character just after the
* last one in the previous lexeme. Used to
* compute size of subexpression tokens. */
CONST char *originalExpr; /* Points to the start of the expression
* originally passed to Tcl_ParseExpr. */
CONST char *lastChar; /* Points just after last byte of expr. */
} ParseInfo;
/*
* Definitions of the different lexemes that appear in expressions. The
* order of these must match the corresponding entries in the
* operatorStrings array below.
*
|
| ︙ | ︙ | |||
144 145 146 147 148 149 150 | /* * Declarations for local procedures to this file: */ static int GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr)); static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr, | | > > | | | 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 | /* * Declarations for local procedures to this file: */ static int GetLexeme _ANSI_ARGS_((ParseInfo *infoPtr)); static void LogSyntaxError _ANSI_ARGS_((ParseInfo *infoPtr, CONST char *extraInfo)); static int ParseAddExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitAndExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitOrExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseBitXorExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseCondExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseEqualityExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseLandExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseLorExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseMaxDoubleLength _ANSI_ARGS_((CONST char *string, CONST char *end)); static int ParseMultiplyExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParsePrimaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseRelationalExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseShiftExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static int ParseUnaryExpr _ANSI_ARGS_((ParseInfo *infoPtr)); static void PrependSubExprTokens _ANSI_ARGS_((CONST char *op, int opBytes, CONST char *src, int srcBytes, int firstIndex, ParseInfo *infoPtr)); /* * Macro used to debug the execution of the recursive descent parser used * to parse expressions. */ |
| ︙ | ︙ | |||
186 187 188 189 190 191 192 | *---------------------------------------------------------------------- * * Tcl_ParseExpr -- * * Given a string, this procedure parses the first Tcl expression * in the string and returns information about the structure of * the expression. This procedure is the top-level interface to the | | > | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 | *---------------------------------------------------------------------- * * Tcl_ParseExpr -- * * Given a string, this procedure parses the first Tcl expression * in the string and returns information about the structure of * the expression. This procedure is the top-level interface to the * the expression parsing module. No more that numBytes bytes will * be scanned. * * Results: * The return value is TCL_OK if the command was parsed successfully * and TCL_ERROR otherwise. If an error occurs and interp isn't NULL * then an error message is left in its result. On a successful return, * parsePtr is filled in with information about the expression that * was parsed. |
| ︙ | ︙ | |||
208 209 210 211 212 213 214 |
*
*----------------------------------------------------------------------
*/
int
Tcl_ParseExpr(interp, string, numBytes, parsePtr)
Tcl_Interp *interp; /* Used for error reporting. */
| | < | 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 |
*
*----------------------------------------------------------------------
*/
int
Tcl_ParseExpr(interp, string, numBytes, parsePtr)
Tcl_Interp *interp; /* Used for error reporting. */
CONST char *string; /* The source string to parse. */
int numBytes; /* Number of bytes in string. If < 0, the
* string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr; /* Structure to fill with information about
* the parsed expression; any previous
* information in the structure is
* ignored. */
{
ParseInfo info;
int code;
if (numBytes < 0) {
numBytes = (string? strlen(string) : 0);
}
#ifdef TCL_COMPILE_DEBUG
if (traceParseExpr) {
fprintf(stderr, "Tcl_ParseExpr: string=\"%.*s\"\n",
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->term = string;
parsePtr->incomplete = 0;
| < < < < < < < < < < < | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 |
parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
parsePtr->string = string;
parsePtr->end = (string + numBytes);
parsePtr->interp = interp;
parsePtr->term = string;
parsePtr->incomplete = 0;
/*
* Initialize the ParseInfo structure that holds state while parsing
* the expression.
*/
info.parsePtr = parsePtr;
info.lexeme = UNKNOWN;
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
if (code != TCL_OK) {
goto error;
}
if (info.lexeme != END) {
LogSyntaxError(&info, "extra tokens at end of expression");
goto error;
}
| < < | | 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 |
if (code != TCL_OK) {
goto error;
}
if (info.lexeme != END) {
LogSyntaxError(&info, "extra tokens at end of expression");
goto error;
}
return TCL_OK;
error:
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree((char *) parsePtr->tokenPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ParseCondExpr --
*
* This procedure parses a Tcl conditional expression:
* condExpr ::= lorExpr ['?' condExpr ':' condExpr]
*
* Note that this is the topmost recursive-descent parsing routine used
* by Tcl_ParseExpr to parse expressions. This avoids an extra procedure
* call since such a procedure would only return the result of calling
* ParseCondExpr. Other recursive-descent procedures that need to parse
* complete expressions also call ParseCondExpr.
*
* Results:
* The return value is TCL_OK on a successful parse and TCL_ERROR
* on failure. If TCL_ERROR is returned, then the interpreter's result
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
ParseCondExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr;
int firstIndex, numToMove, code;
| | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
ParseCondExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Token *tokenPtr, *firstTokenPtr, *condTokenPtr;
int firstIndex, numToMove, code;
CONST char *srcStart;
HERE("condExpr", 1);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseLorExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 |
static int
ParseLorExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
| | | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 |
static int
ParseLorExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("lorExpr", 2);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseLandExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
505 506 507 508 509 510 511 |
static int
ParseLandExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
| | | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
static int
ParseLandExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("landExpr", 3);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseBitOrExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
565 566 567 568 569 570 571 |
static int
ParseBitOrExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
| | | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
static int
ParseBitOrExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("bitOrExpr", 4);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseBitXorExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 |
static int
ParseBitXorExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
| | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
static int
ParseBitXorExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("bitXorExpr", 5);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseBitAndExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
687 688 689 690 691 692 693 |
static int
ParseBitAndExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
| | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
static int
ParseBitAndExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, code;
CONST char *srcStart, *operator;
HERE("bitAndExpr", 6);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseEqualityExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
748 749 750 751 752 753 754 |
static int
ParseEqualityExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
| | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 |
static int
ParseEqualityExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("equalityExpr", 7);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseRelationalExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
812 813 814 815 816 817 818 |
static int
ParseRelationalExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, operatorSize, code;
| | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 |
static int
ParseRelationalExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, operatorSize, code;
CONST char *srcStart, *operator;
HERE("relationalExpr", 8);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseShiftExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
880 881 882 883 884 885 886 |
static int
ParseShiftExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
| | | 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
static int
ParseShiftExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("shiftExpr", 9);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseAddExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 |
static int
ParseAddExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
| | | 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 |
static int
ParseAddExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("addExpr", 10);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseMultiplyExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 |
static int
ParseMultiplyExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
| | | 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
static int
ParseMultiplyExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("multiplyExpr", 11);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
code = ParseUnaryExpr(infoPtr);
if (code != TCL_OK) {
|
| ︙ | ︙ | |||
1066 1067 1068 1069 1070 1071 1072 |
static int
ParseUnaryExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
| | | 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
static int
ParseUnaryExpr(infoPtr)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
int firstIndex, lexeme, code;
CONST char *srcStart, *operator;
HERE("unaryExpr", 12);
srcStart = infoPtr->start;
firstIndex = parsePtr->numTokens;
lexeme = infoPtr->lexeme;
if ((lexeme == PLUS) || (lexeme == MINUS) || (lexeme == BIT_NOT)
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 |
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Interp *interp = parsePtr->interp;
Tcl_Token *tokenPtr, *exprTokenPtr;
Tcl_Parse nested;
| | | 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 |
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
{
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Interp *interp = parsePtr->interp;
Tcl_Token *tokenPtr, *exprTokenPtr;
Tcl_Parse nested;
CONST char *dollarPtr, *stringStart, *termPtr, *src;
int lexeme, exprIndex, firstIndex, numToMove, code;
/*
* We simply recurse on parenthesized subexpressions.
*/
HERE("primaryExpr", 13);
|
| ︙ | ︙ | |||
1390 1391 1392 1393 1394 1395 1396 | * 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. */ Interp *iPtr = (Interp *) infoPtr->parsePtr->interp; | | | > | > < < > | > | > | 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 |
* 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.
*/
Interp *iPtr = (Interp *) infoPtr->parsePtr->interp;
Tcl_DString functionName;
Tcl_HashEntry *hPtr;
/*
* 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, tokenPtr->start,
tokenPtr->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) {
|
| ︙ | ︙ | |||
1521 1522 1523 1524 1525 1526 1527 |
*/
static int
GetLexeme(infoPtr)
ParseInfo *infoPtr; /* Holds state needed to parse the expr,
* including the resulting lexeme. */
{
| | < < | | < | | | | | < < < < | < < < | > < < < < < < < < < < < < < < | < < < < | | < < > > | < < | > > < < < < < < < < < < < < | > > > > | | | < | | | | | | > > > > > > > > > > | < < > > | > | | > > > > | > | | | 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 |
*/
static int
GetLexeme(infoPtr)
ParseInfo *infoPtr; /* Holds state needed to parse the expr,
* including the resulting lexeme. */
{
register CONST char *src; /* Points to current source char. */
char c;
int offset, length, numBytes;
Tcl_Parse *parsePtr = infoPtr->parsePtr;
Tcl_Interp *interp = parsePtr->interp;
Tcl_UniChar ch;
/*
* Record where the previous lexeme ended. Since we always read one
* lexeme ahead during parsing, this helps us know the source length of
* subexpression tokens.
*/
infoPtr->prevEnd = infoPtr->next;
/*
* Scan over leading white space at the start of a lexeme.
*/
src = infoPtr->next;
numBytes = parsePtr->end - src;
do {
char type;
int scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type);
src += scanned; numBytes -= scanned;
} while (numBytes && (*src == '\n') && (src++,numBytes--));
parsePtr->term = src;
if (numBytes == 0) {
infoPtr->lexeme = END;
infoPtr->next = src;
return TCL_OK;
}
/*
* Try to parse the lexeme first as an integer or floating-point
* number. Don't check for a number if the first character c is
* "+" or "-". If we did, we might treat a binary operator as unary
* by mistake, which would eventually cause a syntax error.
*/
c = *src;
if ((c != '+') && (c != '-')) {
CONST char *end = infoPtr->lastChar;
if ((length = TclParseInteger(src, (end - src)))) {
/*
* First length bytes look like an integer. Verify by
* attempting the conversion to the largest integer we have.
*/
int code;
Tcl_WideInt wide;
Tcl_Obj *value = Tcl_NewStringObj(src, length);
Tcl_IncrRefCount(value);
code = Tcl_GetWideIntFromObj(interp, value, &wide);
Tcl_DecrRefCount(value);
if (code == TCL_ERROR) {
parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
return TCL_ERROR;
}
infoPtr->lexeme = LITERAL;
infoPtr->start = src;
infoPtr->size = length;
infoPtr->next = (src + length);
parsePtr->term = infoPtr->next;
return TCL_OK;
} else if ((length = ParseMaxDoubleLength(src, end))) {
/*
* There are length characters that could be a double.
* Let strtod() tells us for sure. Need a writable copy
* so we can set an terminating NULL to keep strtod from
* scanning too far.
*/
char *startPtr, *termPtr;
double doubleValue;
Tcl_DString toParse;
errno = 0;
Tcl_DStringInit(&toParse);
startPtr = Tcl_DStringAppend(&toParse, src, length);
doubleValue = strtod(startPtr, &termPtr);
Tcl_DStringFree(&toParse);
if (termPtr != startPtr) {
if (errno != 0) {
if (interp != NULL) {
TclExprFloatError(interp, doubleValue);
}
parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
return TCL_ERROR;
}
/*
* startPtr was the start of a valid double, copied
* from src.
*/
infoPtr->lexeme = LITERAL;
infoPtr->start = src;
if ((termPtr - startPtr) > length) {
infoPtr->size = length;
} else {
infoPtr->size = (termPtr - startPtr);
}
infoPtr->next = src + infoPtr->size;
parsePtr->term = infoPtr->next;
return TCL_OK;
}
}
}
/*
* Not an integer or double literal. Initialize the lexeme's fields
|
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 | return TCL_OK; case ':': infoPtr->lexeme = COLON; return TCL_OK; case '<': | > > | | | | | | | | | | | < < < | > > > | | | | | | | | | | | < < < | > > | < < > | < < > | < < > | < < | | > > | > > > > > > | > | > > > > > > | 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 |
return TCL_OK;
case ':':
infoPtr->lexeme = COLON;
return TCL_OK;
case '<':
infoPtr->lexeme = LESS;
if ((infoPtr->lastChar - src) > 1) {
switch (src[1]) {
case '<':
infoPtr->lexeme = LEFT_SHIFT;
infoPtr->size = 2;
infoPtr->next = src+2;
break;
case '=':
infoPtr->lexeme = LEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
break;
}
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '>':
infoPtr->lexeme = GREATER;
if ((infoPtr->lastChar - src) > 1) {
switch (src[1]) {
case '>':
infoPtr->lexeme = RIGHT_SHIFT;
infoPtr->size = 2;
infoPtr->next = src+2;
break;
case '=':
infoPtr->lexeme = GEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
break;
}
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '=':
infoPtr->lexeme = UNKNOWN;
if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = EQUAL;
infoPtr->size = 2;
infoPtr->next = src+2;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '!':
infoPtr->lexeme = NOT;
if ((src[1] == '=') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = NEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '&':
infoPtr->lexeme = BIT_AND;
if ((src[1] == '&') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = AND;
infoPtr->size = 2;
infoPtr->next = src+2;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '^':
infoPtr->lexeme = BIT_XOR;
return TCL_OK;
case '|':
infoPtr->lexeme = BIT_OR;
if ((src[1] == '|') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = OR;
infoPtr->size = 2;
infoPtr->next = src+2;
}
parsePtr->term = infoPtr->next;
return TCL_OK;
case '~':
infoPtr->lexeme = BIT_NOT;
return TCL_OK;
case 'e':
if ((src[1] == 'q') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = STREQ;
infoPtr->size = 2;
infoPtr->next = src+2;
parsePtr->term = infoPtr->next;
return TCL_OK;
} else {
goto checkFuncName;
}
case 'n':
if ((src[1] == 'e') && ((infoPtr->lastChar - src) > 1)) {
infoPtr->lexeme = STRNEQ;
infoPtr->size = 2;
infoPtr->next = src+2;
parsePtr->term = infoPtr->next;
return TCL_OK;
} else {
goto checkFuncName;
}
default:
checkFuncName:
length = (infoPtr->lastChar - src);
if (Tcl_UtfCharComplete(src, length)) {
offset = Tcl_UtfToUniChar(src, &ch);
} else {
char utfBytes[TCL_UTF_MAX];
memcpy(utfBytes, src, (size_t) length);
utfBytes[length] = '\0';
offset = Tcl_UtfToUniChar(utfBytes, &ch);
}
c = UCHAR(ch);
if (isalpha(UCHAR(c))) { /* INTL: ISO only. */
infoPtr->lexeme = FUNC_NAME;
while (isalnum(UCHAR(c)) || (c == '_')) { /* INTL: ISO only. */
src += offset; length -= offset;
if (Tcl_UtfCharComplete(src, length)) {
offset = Tcl_UtfToUniChar(src, &ch);
} else {
char utfBytes[TCL_UTF_MAX];
memcpy(utfBytes, src, (size_t) length);
utfBytes[length] = '\0';
offset = Tcl_UtfToUniChar(utfBytes, &ch);
}
c = UCHAR(ch);
}
infoPtr->size = (src - infoPtr->start);
infoPtr->next = src;
parsePtr->term = infoPtr->next;
/*
* Check for boolean literals (true, false, yes, no, on, off)
|
| ︙ | ︙ | |||
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 |
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* PrependSubExprTokens --
*
* This procedure is called after the operands of an subexpression have
* been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for
* the subexpression, and a TCL_TOKEN_OPERATOR token for its operator.
* These two tokens are inserted before the operand tokens.
*
* Results:
* None.
*
* Side effects:
* If there is insufficient space in parsePtr to hold the new tokens,
* additional space is malloc-ed.
*
*----------------------------------------------------------------------
*/
static void
PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr)
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 |
return TCL_OK;
}
}
/*
*----------------------------------------------------------------------
*
* TclParseInteger --
*
* Scans up to numBytes bytes starting at src, and checks whether
* the leading bytes look like an integer's string representation.
*
* Results:
* Returns 0 if the leading bytes do not look like an integer.
* Otherwise, returns the number of bytes examined that look
* like an integer. This may be less than numBytes if the integer
* is only the leading part of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclParseInteger(string, numBytes)
register CONST char *string;/* The string to examine. */
register int numBytes; /* Max number of bytes to scan. */
{
register CONST char *p = string;
/* Take care of introductory "0x" */
if ((numBytes > 1) && (p[0] == '0') && ((p[1] == 'x') || (p[1] == 'X'))) {
int scanned;
Tcl_UniChar ch;
p+=2; numBytes -= 2;
scanned = TclParseHex(p, numBytes, &ch);
if (scanned) {
return scanned + 2;
}
return 0;
}
while (numBytes && isdigit(UCHAR(*p))) { /* INTL: digit */
numBytes--; p++;
}
if (numBytes == 0) {
return (p - string);
}
if ((*p != '.') && (*p != 'e') && (*p != 'E')) {
return (p - string);
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* ParseMaxDoubleLength --
*
* Scans a sequence of bytes checking that the characters could
* be in a string rep of a double.
*
* Results:
* Returns the number of bytes starting with string, runing to, but
* not including end, all of which could be part of a string rep.
* of a double. Only character identity is used, no actual
* parsing is done.
*
* The legal bytes are '0' - '9', 'A' - 'F', 'a' - 'f',
* '.', '+', '-', 'i', 'I', 'n', 'N', 'p', 'P', 'x', and 'X'.
* This covers the values "Inf" and "Nan" as well as the
* decimal and hexadecimal representations recognized by a
* C99-compliant strtod().
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseMaxDoubleLength(string, end)
register CONST char *string;/* The string to examine. */
CONST char *end; /* Point to the first character past the end
* of the string we are examining. */
{
CONST char *p = string;
while (p < end) {
switch (*p) {
case '0': case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9': case 'A': case 'B':
case 'C': case 'D': case 'E': case 'F': case 'I': case 'N':
case 'P': case 'X': case 'a': case 'b': case 'c': case 'd':
case 'e': case 'f': case 'i': case 'n': case 'p': case 'x':
case '.': case '+': case '-':
p++;
break;
default:
goto done;
}
}
done:
return (p - string);
}
/*
*----------------------------------------------------------------------
*
* PrependSubExprTokens --
*
* This procedure is called after the operands of an subexpression have
* been parsed. It generates two tokens: a TCL_TOKEN_SUB_EXPR token for
* the subexpression, and a TCL_TOKEN_OPERATOR token for its operator.
* These two tokens are inserted before the operand tokens.
*
* Results:
* None.
*
* Side effects:
* If there is insufficient space in parsePtr to hold the new tokens,
* additional space is malloc-ed.
*
*----------------------------------------------------------------------
*/
static void
PrependSubExprTokens(op, opBytes, src, srcBytes, firstIndex, infoPtr)
CONST char *op; /* Points to first byte of the operator
* in the source script. */
int opBytes; /* Number of bytes in the operator. */
CONST char *src; /* Points to first byte of the subexpression
* in the source script. */
int srcBytes; /* Number of bytes in subexpression's
* source. */
int firstIndex; /* Index of first token already emitted for
* operator's first (or only) operand. */
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
|
| ︙ | ︙ | |||
1979 1980 1981 1982 1983 1984 1985 |
*----------------------------------------------------------------------
*/
static void
LogSyntaxError(infoPtr, extraInfo)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
| | | | > | 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 |
*----------------------------------------------------------------------
*/
static void
LogSyntaxError(infoPtr, extraInfo)
ParseInfo *infoPtr; /* Holds the parse state for the
* expression being parsed. */
CONST char *extraInfo; /* String to provide extra information
* about the syntax error. */
{
int numBytes = (infoPtr->lastChar - infoPtr->originalExpr);
char buffer[100];
if (numBytes > 60) {
sprintf(buffer, "syntax error in expression \"%.60s...\"",
infoPtr->originalExpr);
} else {
sprintf(buffer, "syntax error in expression \"%.*s\"",
numBytes, infoPtr->originalExpr);
}
Tcl_ResetResult(infoPtr->parsePtr->interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->parsePtr->interp),
buffer, ": ", extraInfo, (char *) NULL);
infoPtr->parsePtr->errorType = TCL_PARSE_SYNTAX;
infoPtr->parsePtr->term = infoPtr->start;
}
|
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.12.6.4 2002/08/20 20:25:26 das Exp $ */ #ifndef _TCLPLATDECLS #define _TCLPLATDECLS /* * Pull in the typedef of TCHAR for windows. |
| ︙ | ︙ | |||
71 72 73 74 75 76 77 | EXTERN int strncasecmp _ANSI_ARGS_((CONST char * s1, CONST char * s2, size_t n)); /* 8 */ EXTERN int strcasecmp _ANSI_ARGS_((CONST char * s1, CONST char * s2)); #endif /* MAC_TCL */ #ifdef MAC_OSX_TCL | < | | | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
EXTERN int strncasecmp _ANSI_ARGS_((CONST char * s1,
CONST char * s2, size_t n));
/* 8 */
EXTERN int strcasecmp _ANSI_ARGS_((CONST char * s1,
CONST char * s2));
#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;
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
int (*tcl_GetOSTypeFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, OSType * osTypePtr)); /* 4 */
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
| < | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
int (*tcl_GetOSTypeFromObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, OSType * osTypePtr)); /* 4 */
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;
|
| ︙ | ︙ | |||
167 168 169 170 171 172 173 | #endif #ifndef strcasecmp #define strcasecmp \ (tclPlatStubsPtr->strcasecmp) /* 8 */ #endif #endif /* MAC_TCL */ #ifdef MAC_OSX_TCL | < | | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | #endif #ifndef strcasecmp #define strcasecmp \ (tclPlatStubsPtr->strcasecmp) /* 8 */ #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 */ |
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 | /* * 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.29.2.3 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclCompile.h" /* * Prototypes for static functions in this file |
| ︙ | ︙ | |||
794 795 796 797 798 799 800 |
TclProcInterpProc(clientData, interp, argc, argv)
ClientData clientData; /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp; /* Interpreter in which procedure was
* invoked. */
int argc; /* Count of number of arguments to this
* procedure. */
| | | 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 |
TclProcInterpProc(clientData, interp, argc, argv)
ClientData clientData; /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp; /* Interpreter in which procedure was
* invoked. */
int argc; /* Count of number of arguments to this
* procedure. */
register CONST char **argv; /* Argument values. */
{
register Tcl_Obj *objPtr;
register int i;
int result;
/*
* This procedure generates an objv array for object arguments that hold
|
| ︙ | ︙ | |||
1003 1004 1005 1006 1007 1008 1009 |
*/
if ((i == numArgs) && ((localPtr->name[0] == 'a')
&& (strcmp(localPtr->name, "args") == 0))) {
Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
varPtr->value.objPtr = listPtr;
Tcl_IncrRefCount(listPtr); /* local var is a reference */
| | | | | 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 |
*/
if ((i == numArgs) && ((localPtr->name[0] == 'a')
&& (strcmp(localPtr->name, "args") == 0))) {
Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
varPtr->value.objPtr = listPtr;
Tcl_IncrRefCount(listPtr); /* local var is a reference */
TclClearVarUndefined(varPtr);
argCt = 0;
break; /* done processing args */
} else if (argCt > 0) {
Tcl_Obj *objPtr = objv[i];
varPtr->value.objPtr = objPtr;
TclClearVarUndefined(varPtr);
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else if (localPtr->defValuePtr != NULL) {
Tcl_Obj *objPtr = localPtr->defValuePtr;
varPtr->value.objPtr = objPtr;
TclClearVarUndefined(varPtr);
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else {
goto incorrectArgs;
}
varPtr++;
localPtr = localPtr->nextPtr;
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 |
fprintf(stdout, "\n");
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
iPtr->returnCode = TCL_OK;
procPtr->refCount++;
| | | 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 |
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);
|
| ︙ | ︙ | |||
1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 |
int
TclUpdateReturnInfo(iPtr)
Interp *iPtr; /* Interpreter for which TCL_RETURN
* exception is being processed. */
{
int code;
code = iPtr->returnCode;
iPtr->returnCode = TCL_OK;
if (code == TCL_ERROR) {
| > < | > > | > | | 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 |
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,
NULL, Tcl_NewStringObj(errorCode, -1),
TCL_GLOBAL_ONLY);
iPtr->flags |= ERROR_CODE_SET;
if (iPtr->errorInfo != NULL) {
Tcl_ObjSetVar2((Tcl_Interp *) iPtr, iPtr->execEnvPtr->errorInfo,
NULL, Tcl_NewStringObj(iPtr->errorInfo, -1),
TCL_GLOBAL_ONLY);
iPtr->flags |= ERR_IN_PROGRESS;
}
}
return code;
}
/*
|
| ︙ | ︙ |
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.61.4.5 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * Remove macros that will interfere with the definitions below. |
| ︙ | ︙ | |||
48 49 50 51 52 53 54 |
TCL_STUB_MAGIC,
NULL,
NULL, /* 0 */
TclAccessDeleteProc, /* 1 */
TclAccessInsertProc, /* 2 */
TclAllocateFreeObjects, /* 3 */
NULL, /* 4 */
| | | | 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 |
TCL_STUB_MAGIC,
NULL,
NULL, /* 0 */
TclAccessDeleteProc, /* 1 */
TclAccessInsertProc, /* 2 */
TclAllocateFreeObjects, /* 3 */
NULL, /* 4 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
TclCleanupChildren, /* 5 */
#endif /* UNIX */
#ifdef __WIN32__
TclCleanupChildren, /* 5 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 5 */
#endif /* MAC_TCL */
TclCleanupCommand, /* 6 */
TclCopyAndCollapse, /* 7 */
TclCopyChannel, /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
TclCreatePipeline, /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
TclCreatePipeline, /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 9 */
|
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
TclFindElement, /* 22 */
TclFindProc, /* 23 */
TclFormatInt, /* 24 */
TclFreePackageInfo, /* 25 */
NULL, /* 26 */
TclGetDate, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
| | | | | | 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 |
TclFindElement, /* 22 */
TclFindProc, /* 23 */
TclFormatInt, /* 24 */
TclFreePackageInfo, /* 25 */
NULL, /* 26 */
TclGetDate, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
NULL, /* 29 */
NULL, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
TclGetInterpProc, /* 33 */
TclGetIntForIndex, /* 34 */
NULL, /* 35 */
TclGetLong, /* 36 */
TclGetLoadedPackages, /* 37 */
TclGetNamespaceForQualName, /* 38 */
TclGetObjInterpProc, /* 39 */
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
TclpGetUserHome, /* 42 */
TclGlobalInvoke, /* 43 */
TclGuessPackageName, /* 44 */
TclHideUnsafeCommands, /* 45 */
TclInExit, /* 46 */
NULL, /* 47 */
NULL, /* 48 */
TclIncrVar2, /* 49 */
TclInitCompiledLocals, /* 50 */
TclInterpInit, /* 51 */
TclInvoke, /* 52 */
TclInvokeObjectCommand, /* 53 */
TclInvokeStringCommand, /* 54 */
TclIsProc, /* 55 */
|
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
TclProcCompileProc, /* 92 */
TclProcDeleteProc, /* 93 */
TclProcInterpProc, /* 94 */
NULL, /* 95 */
TclRenameCommand, /* 96 */
TclResetShadowedCmdRefs, /* 97 */
TclServiceIdle, /* 98 */
| | | | | | 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 |
TclProcCompileProc, /* 92 */
TclProcDeleteProc, /* 93 */
TclProcInterpProc, /* 94 */
NULL, /* 95 */
TclRenameCommand, /* 96 */
TclResetShadowedCmdRefs, /* 97 */
TclServiceIdle, /* 98 */
NULL, /* 99 */
NULL, /* 100 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
TclSetPreInitScript, /* 101 */
#endif /* UNIX */
#ifdef __WIN32__
TclSetPreInitScript, /* 101 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 101 */
#endif /* MAC_TCL */
TclSetupEnv, /* 102 */
TclSockGetPort, /* 103 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
TclSockMinimumBuffers, /* 104 */
#endif /* UNIX */
#ifdef __WIN32__
TclSockMinimumBuffers, /* 104 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 104 */
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 252 253 254 255 256 |
TclGetInstructionTable, /* 163 */
TclExpandCodeArray, /* 164 */
TclpSetInitialEncodings, /* 165 */
TclListObjSetElement, /* 166 */
TclSetStartupScriptPath, /* 167 */
TclGetStartupScriptPath, /* 168 */
TclpUtfNcmp2, /* 169 */
};
TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
NULL,
| > > | > > > > | 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 |
TclGetInstructionTable, /* 163 */
TclExpandCodeArray, /* 164 */
TclpSetInitialEncodings, /* 165 */
TclListObjSetElement, /* 166 */
TclSetStartupScriptPath, /* 167 */
TclGetStartupScriptPath, /* 168 */
TclpUtfNcmp2, /* 169 */
TclCheckInterpTraces, /* 170 */
TclCheckExecutionTraces, /* 171 */
};
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, /* 11 */
TclpGmtime, /* 12 */
TclpInetNtoa, /* 13 */
#endif /* UNIX */
#ifdef __WIN32__
TclWinConvertError, /* 0 */
TclWinConvertWSAError, /* 1 */
TclWinGetServByName, /* 2 */
TclWinGetSockOpt, /* 3 */
TclWinGetTclInstance, /* 4 */
|
| ︙ | ︙ | |||
342 343 344 345 346 347 348 |
Tcl_GetOSTypeFromObj, /* 4 */
Tcl_SetOSTypeObj, /* 5 */
Tcl_NewOSTypeObj, /* 6 */
strncasecmp, /* 7 */
strcasecmp, /* 8 */
#endif /* MAC_TCL */
#ifdef MAC_OSX_TCL
| < | | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 |
Tcl_GetOSTypeFromObj, /* 4 */
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
|
| ︙ | ︙ | |||
365 366 367 368 369 370 371 |
Tcl_Panic, /* 2 */
Tcl_Alloc, /* 3 */
Tcl_Free, /* 4 */
Tcl_Realloc, /* 5 */
Tcl_DbCkalloc, /* 6 */
Tcl_DbCkfree, /* 7 */
Tcl_DbCkrealloc, /* 8 */
| | | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
Tcl_Panic, /* 2 */
Tcl_Alloc, /* 3 */
Tcl_Free, /* 4 */
Tcl_Realloc, /* 5 */
Tcl_DbCkalloc, /* 6 */
Tcl_DbCkfree, /* 7 */
Tcl_DbCkrealloc, /* 8 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
Tcl_CreateFileHandler, /* 9 */
#endif /* UNIX */
#ifdef __WIN32__
NULL, /* 9 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 9 */
#endif /* MAC_TCL */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
Tcl_DeleteFileHandler, /* 10 */
#endif /* UNIX */
#ifdef __WIN32__
NULL, /* 10 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 10 */
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 |
Tcl_DeleteCommandFromToken, /* 104 */
Tcl_DeleteEvents, /* 105 */
Tcl_DeleteEventSource, /* 106 */
Tcl_DeleteExitHandler, /* 107 */
Tcl_DeleteHashEntry, /* 108 */
Tcl_DeleteHashTable, /* 109 */
Tcl_DeleteInterp, /* 110 */
| | | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 |
Tcl_DeleteCommandFromToken, /* 104 */
Tcl_DeleteEvents, /* 105 */
Tcl_DeleteEventSource, /* 106 */
Tcl_DeleteExitHandler, /* 107 */
Tcl_DeleteHashEntry, /* 108 */
Tcl_DeleteHashTable, /* 109 */
Tcl_DeleteInterp, /* 110 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
Tcl_DetachPids, /* 111 */
#endif /* UNIX */
#ifdef __WIN32__
Tcl_DetachPids, /* 111 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 111 */
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
Tcl_GetCommandName, /* 160 */
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
Tcl_GetMaster, /* 164 */
Tcl_GetNameOfExecutable, /* 165 */
Tcl_GetObjResult, /* 166 */
| | | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
Tcl_GetCommandName, /* 160 */
Tcl_GetErrno, /* 161 */
Tcl_GetHostName, /* 162 */
Tcl_GetInterpPath, /* 163 */
Tcl_GetMaster, /* 164 */
Tcl_GetNameOfExecutable, /* 165 */
Tcl_GetObjResult, /* 166 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
Tcl_GetOpenFile, /* 167 */
#endif /* UNIX */
#ifdef __WIN32__
NULL, /* 167 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 167 */
|
| ︙ | ︙ | |||
585 586 587 588 589 590 591 |
Tcl_MakeSafe, /* 190 */
Tcl_MakeTcpClientChannel, /* 191 */
Tcl_Merge, /* 192 */
Tcl_NextHashEntry, /* 193 */
Tcl_NotifyChannel, /* 194 */
Tcl_ObjGetVar2, /* 195 */
Tcl_ObjSetVar2, /* 196 */
| | | | 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 |
Tcl_MakeSafe, /* 190 */
Tcl_MakeTcpClientChannel, /* 191 */
Tcl_Merge, /* 192 */
Tcl_NextHashEntry, /* 193 */
Tcl_NotifyChannel, /* 194 */
Tcl_ObjGetVar2, /* 195 */
Tcl_ObjSetVar2, /* 196 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
Tcl_OpenCommandChannel, /* 197 */
#endif /* UNIX */
#ifdef __WIN32__
Tcl_OpenCommandChannel, /* 197 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 197 */
#endif /* MAC_TCL */
Tcl_OpenFileChannel, /* 198 */
Tcl_OpenTcpClient, /* 199 */
Tcl_OpenTcpServer, /* 200 */
Tcl_Preserve, /* 201 */
Tcl_PrintDouble, /* 202 */
Tcl_PutEnv, /* 203 */
Tcl_PosixError, /* 204 */
Tcl_QueueEvent, /* 205 */
Tcl_Read, /* 206 */
#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */
Tcl_ReapDetachedProcs, /* 207 */
#endif /* UNIX */
#ifdef __WIN32__
Tcl_ReapDetachedProcs, /* 207 */
#endif /* __WIN32__ */
#ifdef MAC_TCL
NULL, /* 207 */
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 1993-1994 The Regents of the University of California. * Copyright (c) 1994-1997 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. * | | < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | * Copyright (c) 1993-1994 The Regents of the University of California. * Copyright (c) 1994-1997 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: tclTest.c,v 1.32.2.3 2002/08/20 20:25:26 das Exp $ */ #define TCL_TEST #include "tclInt.h" #include "tclPort.h" /* * Required for Testregexp*Cmd */ #include "tclRegexp.h" |
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int code)); static void CleanupTestSetassocdataTests _ANSI_ARGS_(( ClientData clientData, Tcl_Interp *interp)); static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData)); static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData)); static int CmdProc1 _ANSI_ARGS_((ClientData clientData, | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | > | | | | | | | | | < < | | | 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 |
static int AsyncHandlerProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int code));
static void CleanupTestSetassocdataTests _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static void CmdTraceDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *cmdProc,
ClientData cmdClientData, int argc,
char **argv));
static void CmdTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int level, char *command,
Tcl_CmdProc *cmdProc, ClientData cmdClientData,
int argc, char **argv));
static int CreatedCommandProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int argc, CONST char **argv));
static int CreatedCommandProc2 _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int argc, CONST char **argv));
static void DelCallbackProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
static int DelCmdProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static void DelDeleteProc _ANSI_ARGS_((ClientData clientData));
static void EncodingFreeProc _ANSI_ARGS_((ClientData clientData));
static int EncodingToUtfProc _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 EncodingFromUtfProc _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 ExitProcEven _ANSI_ARGS_((ClientData clientData));
static void ExitProcOdd _ANSI_ARGS_((ClientData clientData));
static int GetTimesCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static void MainLoop _ANSI_ARGS_((void));
static int NoopCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static int NoopObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int ObjTraceProc _ANSI_ARGS_(( ClientData clientData,
Tcl_Interp* interp,
int level,
CONST char* command,
Tcl_Command commandToken,
int objc,
Tcl_Obj *CONST objv[] ));
static void ObjTraceDeleteProc _ANSI_ARGS_(( ClientData ));
static void PrintParse _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Parse *parsePtr));
static void SpecialFree _ANSI_ARGS_((char *blockPtr));
static int StaticInitProc _ANSI_ARGS_((Tcl_Interp *interp));
static int TestaccessprocCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int PretendTclpAccess _ANSI_ARGS_((CONST char *path,
int mode));
static int TestAccessProc1 _ANSI_ARGS_((CONST char *path,
int mode));
static int TestAccessProc2 _ANSI_ARGS_((CONST char *path,
int mode));
static int TestAccessProc3 _ANSI_ARGS_((CONST char *path,
int mode));
static int TestasyncCmd _ANSI_ARGS_((ClientData dummy,
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 TestchmodCmd _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,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestdstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestencodingObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestevalexObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestevalobjvObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexprparserObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int TestfilelinkCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
static int TestfeventCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetassocdataCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetplatformCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestgetvarfullnameCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestinterpdeleteCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestlinkCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestlocaleCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestMathFunc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
Tcl_Value *resultPtr));
static int TestMathFunc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
Tcl_Value *resultPtr));
static int TestmainthreadCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestsetmainloopCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestexitmainloopCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static Tcl_Channel PretendTclpOpenFileChannel _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *fileName,
CONST char *modeString, int permissions));
static Tcl_Channel TestOpenFileChannelProc1 _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *fileName,
CONST char *modeString, int permissions));
static Tcl_Channel TestOpenFileChannelProc2 _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *fileName,
CONST char *modeString, int permissions));
static Tcl_Channel TestOpenFileChannelProc3 _ANSI_ARGS_((
Tcl_Interp *interp, CONST char *fileName,
CONST char *modeString, int permissions));
static int TestpanicCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestparserObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestparsevarObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestparsevarnameObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static int TestregexpObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static void TestregexpXflags _ANSI_ARGS_((char *string,
int length, int *cflagsPtr, int *eflagsPtr));
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));
static int TestsetplatformCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TeststaticpkgCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int PretendTclpStat _ANSI_ARGS_((CONST char *path,
struct stat *buf));
static int TestStatProc1 _ANSI_ARGS_((CONST char *path,
struct stat *buf));
static int TestStatProc2 _ANSI_ARGS_((CONST char *path,
struct stat *buf));
static int TestStatProc3 _ANSI_ARGS_((CONST char *path,
struct stat *buf));
static int TeststatprocCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TesttranslatefilenameCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestupvarCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestWrongNumArgsObjCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestGetIndexFromObjStructObjCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int TestChannelCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
static int TestChannelEventCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, CONST char **argv));
/* Filesystem testing */
static int TestFilesystemObjCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
static void TestReport _ANSI_ARGS_((CONST char* cmd, Tcl_Obj* arg1, Tcl_Obj* arg2));
static Tcl_Obj *TestReportGetNativePath(Tcl_Obj* pathObjPtr);
static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path,
Tcl_StatBuf *buf));
static int TestReportAccess _ANSI_ARGS_ ((Tcl_Obj *path,
int mode));
static Tcl_Channel TestReportOpenFileChannel _ANSI_ARGS_ ((
Tcl_Interp *interp, Tcl_Obj *fileName,
int mode, int permissions));
static int TestReportMatchInDirectory _ANSI_ARGS_ ((
Tcl_Interp *interp, Tcl_Obj *resultPtr,
Tcl_Obj *dirPtr, CONST char *pattern,
Tcl_GlobTypeData *types));
static int TestReportChdir _ANSI_ARGS_ ((Tcl_Obj *dirName));
static int TestReportLstat _ANSI_ARGS_ ((Tcl_Obj *path,
Tcl_StatBuf *buf));
static int TestReportCopyFile _ANSI_ARGS_ ((Tcl_Obj *src,
Tcl_Obj *dst));
static int TestReportDeleteFile _ANSI_ARGS_ ((Tcl_Obj *path));
static int TestReportRenameFile _ANSI_ARGS_ ((Tcl_Obj *src,
Tcl_Obj *dst));
static int TestReportCreateDirectory _ANSI_ARGS_ ((Tcl_Obj *path));
static int TestReportCopyDirectory _ANSI_ARGS_ ((Tcl_Obj *src,
Tcl_Obj *dst, Tcl_Obj **errorPtr));
static int TestReportRemoveDirectory _ANSI_ARGS_ ((Tcl_Obj *path,
int recursive, Tcl_Obj **errorPtr));
static int TestReportLoadFile _ANSI_ARGS_ ((Tcl_Interp *interp,
Tcl_Obj *fileName,
Tcl_LoadHandle *handlePtr,
Tcl_FSUnloadFileProc **unloadProcPtr));
static Tcl_Obj * TestReportLink _ANSI_ARGS_ ((Tcl_Obj *path,
Tcl_Obj *to, int linkType));
static CONST char** TestReportFileAttrStrings _ANSI_ARGS_ ((
Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
static int TestReportFileAttrsGet _ANSI_ARGS_ ((Tcl_Interp *interp,
int index, Tcl_Obj *fileName, Tcl_Obj **objPtrRef));
static int TestReportFileAttrsSet _ANSI_ARGS_ ((Tcl_Interp *interp,
int index, Tcl_Obj *fileName, Tcl_Obj *objPtr));
static int TestReportUtime _ANSI_ARGS_ ((Tcl_Obj *fileName,
|
| ︙ | ︙ | |||
521 522 523 524 525 526 527 528 529 530 531 532 533 534 |
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
| > > | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 |
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testexprparser", TestexprparserObjCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfevent", TestfeventCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testfilelink", TestfilelinkCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateObjCommand(interp, "testgetvarfullname",
|
| ︙ | ︙ | |||
658 659 660 661 662 663 664 |
/* ARGSUSED */
static int
TestasyncCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 |
/* ARGSUSED */
static int
TestasyncCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
char buf[TCL_INTEGER_SPACE];
if (argc < 2) {
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
| | | | | | 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 |
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
Tcl_AsyncMark(asyncPtr->handler);
break;
}
}
Tcl_SetResult(interp, (char *)argv[3], TCL_VOLATILE);
return code;
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, int, or mark",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
AsyncHandlerProc(clientData, interp, code)
ClientData clientData; /* Pointer to TestAsyncHandler structure. */
Tcl_Interp *interp; /* Interpreter in which command was
* executed, or NULL. */
int code; /* Current return code from command. */
{
TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
CONST char *listArgv[4], *cmd;
char string[TCL_INTEGER_SPACE];
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
code = Tcl_Eval(interp, cmd);
} else {
/*
* this should not happen, but by definition of how async
* handlers are invoked, it's possible. Better error
* checking is needed here.
*/
}
ckfree((char *)cmd);
return code;
}
/*
*----------------------------------------------------------------------
*
* TestcmdinfoCmd --
|
| ︙ | ︙ | |||
797 798 799 800 801 802 803 |
/* ARGSUSED */
static int
TestcmdinfoCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 |
/* ARGSUSED */
static int
TestcmdinfoCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option cmdName\"", (char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 |
/*ARGSUSED*/
static int
CmdProc1(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | | 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 |
/*ARGSUSED*/
static int
CmdProc1(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
(char *) NULL);
return TCL_OK;
}
/*ARGSUSED*/
static int
CmdProc2(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
(char *) NULL);
return TCL_OK;
}
static void
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 |
/* ARGSUSED */
static int
TestcmdtokenCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
/* ARGSUSED */
static int
TestcmdtokenCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_Command token;
int *l;
char buf[30];
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
| ︙ | ︙ | |||
996 997 998 999 1000 1001 1002 |
/* ARGSUSED */
static int
TestcmdtraceCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 |
/* ARGSUSED */
static int
TestcmdtraceCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_DString buffer;
int result;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option script\"", (char *) NULL);
|
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 |
*/
static int
TestcreatecommandCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
*/
static int
TestcreatecommandCmd(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 != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
|
| ︙ | ︙ | |||
1203 1204 1205 1206 1207 1208 1209 |
}
static int
CreatedCommandProc(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 |
}
static int
CreatedCommandProc(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand",
&info);
if (!found) {
|
| ︙ | ︙ | |||
1225 1226 1227 1228 1229 1230 1231 |
}
static int
CreatedCommandProc2(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 |
}
static int
CreatedCommandProc2(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
int found;
found = Tcl_GetCommandInfo(interp, "value:at:", &info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",
|
| ︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 |
/* ARGSUSED */
static int
TestdcallCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 |
/* ARGSUSED */
static int
TestdcallCmd(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, id;
delInterp = Tcl_CreateInterp();
Tcl_DStringInit(&delString);
for (i = 1; i < argc; i++) {
if (Tcl_GetInt(interp, argv[i], &id) != TCL_OK) {
|
| ︙ | ︙ | |||
1330 1331 1332 1333 1334 1335 1336 |
/* ARGSUSED */
static int
TestdelCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 |
/* ARGSUSED */
static int
TestdelCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
DelCmd *dPtr;
Tcl_Interp *slave;
if (argc != 4) {
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1360 1361 1362 1363 1364 1365 1366 |
}
static int
DelCmdProc(clientData, interp, argc, argv)
ClientData clientData; /* String result to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
}
static int
DelCmdProc(clientData, interp, argc, argv)
ClientData clientData; /* String result to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
DelCmd *dPtr = (DelCmd *) clientData;
Tcl_AppendResult(interp, dPtr->deleteCmd, (char *) NULL);
ckfree(dPtr->deleteCmd);
ckfree((char *) dPtr);
return TCL_OK;
|
| ︙ | ︙ | |||
1405 1406 1407 1408 1409 1410 1411 |
*/
static int
TestdelassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 |
*/
static int
TestdelassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key\"", (char *) NULL);
return TCL_ERROR;
}
Tcl_DeleteAssocData(interp, argv[1]);
|
| ︙ | ︙ | |||
1439 1440 1441 1442 1443 1444 1445 |
/* ARGSUSED */
static int
TestdstringCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
/* ARGSUSED */
static int
TestdstringCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int count;
if (argc < 2) {
wrongNumArgs:
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1846 1847 1848 1849 1850 1851 1852 |
*/
static int
TestexithandlerCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 |
*/
static int
TestexithandlerCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int value;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" create|delete value\"", (char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1914 1915 1916 1917 1918 1919 1920 |
*/
static int
TestexprlongCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 |
*/
static int
TestexprlongCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
long exprResult;
char buf[4 + TCL_INTEGER_SPACE];
int result;
Tcl_SetResult(interp, "This is a result", TCL_STATIC);
result = Tcl_ExprLong(interp, "4+1", &exprResult);
|
| ︙ | ︙ | |||
1951 1952 1953 1954 1955 1956 1957 |
*/
static int
TestexprstringCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*/
static int
TestexprstringCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" expression\"", (char *) NULL);
return TCL_ERROR;
}
return Tcl_ExprString(interp, argv[1]);
}
/*
*----------------------------------------------------------------------
*
* TestfilelinkCmd --
*
* This procedure implements the "testfilelink" command. It is used
* to test the effects of creating and manipulating filesystem links
* in Tcl.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* May create a link on disk.
*
*----------------------------------------------------------------------
*/
static int
TestfilelinkCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
Tcl_Obj *contents;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "source ?target?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
if (objc == 3) {
/* Create link from source to target */
contents = Tcl_FSLink(objv[1], objv[2],
TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not create link from \"",
Tcl_GetString(objv[1]), "\" to \"",
Tcl_GetString(objv[2]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
} else {
/* Read link */
contents = Tcl_FSLink(objv[1], NULL, 0);
if (contents == NULL) {
Tcl_AppendResult(interp, "could not read link \"",
Tcl_GetString(objv[1]), "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, contents);
if (objc == 2) {
/*
* If we are creating a link, this will actually just
* be objv[3], and we don't own it
*/
Tcl_DecrRefCount(contents);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestgetassocdataCmd --
*
* This procedure implements the "testgetassocdata" command. It is
|
| ︙ | ︙ | |||
1983 1984 1985 1986 1987 1988 1989 |
*/
static int
TestgetassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 |
*/
static int
TestgetassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
char *res;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key\"", (char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2021 2022 2023 2024 2025 2026 2027 |
*/
static int
TestgetplatformCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 |
*/
static int
TestgetplatformCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
static CONST char *platformStrings[] = { "unix", "mac", "windows" };
TclPlatformType *platform;
#ifdef __WIN32__
platform = TclWinGetPlatform();
#else
|
| ︙ | ︙ | |||
2066 2067 2068 2069 2070 2071 2072 |
/* ARGSUSED */
static int
TestinterpdeleteCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 |
/* ARGSUSED */
static int
TestinterpdeleteCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_Interp *slaveToDelete;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" path\"", (char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 |
/* ARGSUSED */
static int
TestlinkCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 |
/* ARGSUSED */
static int
TestlinkCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
static Tcl_WideInt wideVar = Tcl_LongAsWide(79);
static char *stringVar = NULL;
static int created = 0;
|
| ︙ | ︙ | |||
2752 2753 2754 2755 2756 2757 2758 |
TestparsevarObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
CONST char *value;
| | | 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 |
TestparsevarObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
CONST char *value;
CONST char *name, *termPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName");
return TCL_ERROR;
}
name = Tcl_GetString(objv[1]);
value = Tcl_ParseVar(interp, name, &termPtr);
|
| ︙ | ︙ | |||
3189 3190 3191 3192 3193 3194 3195 |
*/
static int
TestsetassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 |
*/
static int
TestsetassocdataCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
char *buf;
char *oldData;
Tcl_InterpDeleteProc *procPtr;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
|
| ︙ | ︙ | |||
3242 3243 3244 3245 3246 3247 3248 |
*/
static int
TestsetplatformCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 |
*/
static int
TestsetplatformCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
size_t length;
TclPlatformType *platform;
#ifdef __WIN32__
platform = TclWinGetPlatform();
#else
|
| ︙ | ︙ | |||
3297 3298 3299 3300 3301 3302 3303 |
*/
static int
TeststaticpkgCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 |
*/
static int
TeststaticpkgCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int safe, loaded;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
argv[0], " pkgName safe loaded\"", (char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
3348 3349 3350 3351 3352 3353 3354 |
*/
static int
TesttranslatefilenameCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 |
*/
static int
TesttranslatefilenameCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_DString buffer;
CONST char *result;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
argv[0], " path\"", (char *) NULL);
|
| ︙ | ︙ | |||
3390 3391 3392 3393 3394 3395 3396 |
/* ARGSUSED */
static int
TestupvarCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 |
/* ARGSUSED */
static int
TestupvarCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int flags = 0;
if ((argc != 5) && (argc != 6)) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
argv[0], " level name ?name2? dest global\"", (char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
3482 3483 3484 3485 3486 3487 3488 |
/* ARGSUSED */
static int
TestfeventCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 |
/* ARGSUSED */
static int
TestfeventCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
static Tcl_Interp *interp2 = NULL;
int code;
Tcl_Channel chan;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
| ︙ | ︙ | |||
3514 3515 3516 3517 3518 3519 3520 |
return TCL_ERROR;
}
} else if (strcmp(argv[1], "create") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
}
interp2 = Tcl_CreateInterp();
| | | 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 |
return TCL_ERROR;
}
} else if (strcmp(argv[1], "create") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
}
interp2 = Tcl_CreateInterp();
return Tcl_Init(interp2);
} else if (strcmp(argv[1], "delete") == 0) {
if (interp2 != NULL) {
Tcl_DeleteInterp(interp2);
}
interp2 = NULL;
} else if (strcmp(argv[1], "share") == 0) {
if (interp2 != NULL) {
|
| ︙ | ︙ | |||
3554 3555 3556 3557 3558 3559 3560 |
*/
static int
TestpanicCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | | | | 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 |
*/
static int
TestpanicCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
CONST char *argString;
/*
* Put the arguments into a var args structure
* Append all of the arguments together separated by spaces
*/
argString = Tcl_Merge(argc-1, argv+1);
panic(argString);
ckfree((char *)argString);
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3594 3595 3596 3597 3598 3599 3600 |
*/
static int
TestchmodCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 |
*/
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],
|
| ︙ | ︙ | |||
3797 3798 3799 3800 3801 3802 3803 |
*/
static int
GetTimesCmd(unused, interp, argc, argv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
| | | 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 |
*/
static int
GetTimesCmd(unused, interp, argc, argv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
CONST char **argv; /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
int i, n;
double timePer;
Tcl_Time start, stop;
Tcl_Obj *objPtr;
Tcl_Obj **objv;
|
| ︙ | ︙ | |||
3977 3978 3979 3980 3981 3982 3983 |
*/
static int
NoopCmd(unused, interp, argc, argv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
| | | 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 |
*/
static int
NoopCmd(unused, interp, argc, argv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
CONST char **argv; /* The argument strings. */
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4032 4033 4034 4035 4036 4037 4038 |
/* ARGSUSED */
static int
TestsetCmd(data, interp, argc, argv)
ClientData data; /* Additional flags for Get/SetVar2. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 |
/* ARGSUSED */
static int
TestsetCmd(data, interp, argc, argv)
ClientData data; /* Additional flags for Get/SetVar2. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int flags = (int) data;
CONST char *value;
if (argc == 2) {
Tcl_SetResult(interp, "before get", TCL_STATIC);
value = Tcl_GetVar2(interp, argv[1], (char *) NULL, flags);
|
| ︙ | ︙ | |||
4214 4215 4216 4217 4218 4219 4220 |
*/
static int
TeststatprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 |
*/
static int
TeststatprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TclStatProc_ *proc;
int retVal;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " option arg\"", (char *) NULL);
|
| ︙ | ︙ | |||
4402 4403 4404 4405 4406 4407 4408 |
*/
static int
TestmainthreadCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 |
*/
static int
TestmainthreadCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc == 1) {
Tcl_Obj *idObj = Tcl_NewLongObj((long)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
|
| ︙ | ︙ | |||
4462 4463 4464 4465 4466 4467 4468 |
*/
static int
TestsetmainloopCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 |
*/
static int
TestsetmainloopCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
4491 4492 4493 4494 4495 4496 4497 |
*/
static int
TestexitmainloopCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 |
*/
static int
TestexitmainloopCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
exitMainLoop = 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4519 4520 4521 4522 4523 4524 4525 |
*/
static int
TestaccessprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 |
*/
static int
TestaccessprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TclAccessProc_ *proc;
int retVal;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " option arg\"", (char *) NULL);
|
| ︙ | ︙ | |||
4631 4632 4633 4634 4635 4636 4637 |
*/
static int
TestopenfilechannelprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 |
*/
static int
TestopenfilechannelprocCmd (dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
register Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
TclOpenFileChannelProc_ *proc;
int retVal;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " option arg\"", (char *) NULL);
|
| ︙ | ︙ | |||
4697 4698 4699 4700 4701 4702 4703 |
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel ret;
| > > > > > > | | > > > > > > > > > > > > > > | 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 |
CONST char *modeString; /* A list of POSIX open modes or
* a string such as "rw". */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel ret;
int mode, seekFlag;
Tcl_Obj *pathPtr;
mode = TclGetOpenMode(interp, modeString, &seekFlag);
if (mode == -1) {
return NULL;
}
pathPtr = Tcl_NewStringObj(fileName, -1);
Tcl_IncrRefCount(pathPtr);
ret = TclpOpenFileChannel(interp, pathPtr, mode, permissions);
Tcl_DecrRefCount(pathPtr);
if (ret != NULL) {
if (seekFlag) {
if (Tcl_Seek(ret, (Tcl_WideInt)0, SEEK_END) < (Tcl_WideInt)0) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp,
"could not seek to end of file while opening \"",
fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
Tcl_Close(NULL, ret);
return NULL;
}
}
}
return ret;
}
static Tcl_Channel
TestOpenFileChannelProc1(interp, fileName, modeString, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
|
| ︙ | ︙ | |||
4810 4811 4812 4813 4814 4815 4816 |
/* ARGSUSED */
static int
TestChannelCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter for result. */
int argc; /* Count of additional args. */
| | | | 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 |
/* ARGSUSED */
static int
TestChannelCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter for result. */
int argc; /* Count of additional args. */
CONST char **argv; /* Additional arg strings. */
{
CONST char *cmdName; /* Sub command. */
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Channel *chanPtr; /* The actual channel. */
ChannelState *statePtr; /* state info for channel */
Tcl_Channel chan; /* The opaque type. */
size_t len; /* Length of subcommand string. */
|
| ︙ | ︙ | |||
5238 5239 5240 5241 5242 5243 5244 |
/* ARGSUSED */
static int
TestChannelEventCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | | 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 |
/* ARGSUSED */
static int
TestChannelEventCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_Obj *resultListPtr;
Channel *chanPtr;
ChannelState *statePtr; /* state info for channel */
EventScriptRecord *esPtr, *prevEsPtr, *nextEsPtr;
CONST char *cmd;
int index, i, mask, len;
if ((argc < 3) || (argc > 5)) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" channelName cmd ?arg1? ?arg2?\"", (char *) NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
5508 5509 5510 5511 5512 5513 5514 |
static int
TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
| | | 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 |
static int
TestGetIndexFromObjStructObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *ary[] = {
"a", "b", "c", "d", "e", "f", (char *)NULL,(char *)NULL
};
int idx,target;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "argument targetvalue");
return TCL_ERROR;
|
| ︙ | ︙ | |||
5696 5697 5698 5699 5700 5701 5702 |
Tcl_Obj *path; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
TestReport("access",path,NULL);
return Tcl_FSAccess(TestReportGetNativePath(path),mode);
}
static Tcl_Channel
| | | < | | | 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 |
Tcl_Obj *path; /* Path of file to access (in current CP). */
int mode; /* Permission setting. */
{
TestReport("access",path,NULL);
return Tcl_FSAccess(TestReportGetNativePath(path),mode);
}
static Tcl_Channel
TestReportOpenFileChannel(interp, fileName, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *fileName; /* Name of file to open. */
int mode; /* POSIX open mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
TestReport("open",fileName, NULL);
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; /* Directory separators to pass to TclDoGlob. */
Tcl_Obj *dirPtr; /* Contains path to directory to search. */
|
| ︙ | ︙ | |||
5733 5734 5735 5736 5737 5738 5739 |
TestReportChdir(dirName)
Tcl_Obj *dirName;
{
TestReport("chdir",dirName,NULL);
return Tcl_FSChdir(TestReportGetNativePath(dirName));
}
static int
| | | < < < < < | | | | > | | | 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 |
TestReportChdir(dirName)
Tcl_Obj *dirName;
{
TestReport("chdir",dirName,NULL);
return Tcl_FSChdir(TestReportGetNativePath(dirName));
}
static int
TestReportLoadFile(interp, fileName,
handlePtr, unloadProcPtr)
Tcl_Interp *interp; /* Used for error reporting. */
Tcl_Obj *fileName; /* Name of the file containing the desired
* code. */
Tcl_LoadHandle *handlePtr; /* 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. */
{
TestReport("loadfile",fileName,NULL);
return Tcl_FSLoadFile(interp, TestReportGetNativePath(fileName), NULL, NULL,
NULL, NULL, handlePtr, unloadProcPtr);
}
static Tcl_Obj *
TestReportLink(path, to, linkType)
Tcl_Obj *path; /* Path of file to readlink or link */
Tcl_Obj *to; /* Path of file to link to, or NULL */
int linkType;
{
TestReport("link",path,to);
return Tcl_FSLink(TestReportGetNativePath(path), to, linkType);
}
static int
TestReportRenameFile(src, dst)
Tcl_Obj *src; /* Pathname of file or dir to be renamed
* (UTF-8). */
Tcl_Obj *dst; /* New pathname of file or directory
* (UTF-8). */
|
| ︙ | ︙ |
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.17.4.3 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" /* * Include the static character classification tables and macros. */ |
| ︙ | ︙ | |||
57 58 59 60 61 62 63 | #define UNICODE_SELF 0x80 /* * The following structures are used when mapping between Unicode (UCS-2) * and UTF-8. */ | | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 |
#define UNICODE_SELF 0x80
/*
* The following structures are used when mapping between Unicode (UCS-2)
* and UTF-8.
*/
static CONST unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
|
| ︙ | ︙ | |||
774 775 776 777 778 779 780 |
CONST char *src; /* Points to the backslash character of
* a backslash sequence. */
int *readPtr; /* Fill in with number of characters read
* from src, unless NULL. */
char *dst; /* Filled with the bytes represented by the
* backslash sequence. */
{
| < < < < | < < < | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < | < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | < < < | | | 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 |
CONST char *src; /* Points to the backslash character of
* a backslash sequence. */
int *readPtr; /* Fill in with number of characters read
* from src, unless NULL. */
char *dst; /* Filled with the bytes represented by the
* backslash sequence. */
{
#define LINE_LENGTH 128
int numRead;
int result;
result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst);
if (numRead == LINE_LENGTH) {
/* We ate a whole line. Pay the price of a strlen() */
result = TclParseBackslash(src, (int)strlen(src), &numRead, dst);
}
if (readPtr != NULL) {
*readPtr = numRead;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UtfToUpper --
*
|
| ︙ | ︙ |
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.24.2.3 2002/08/20 20:25:26 das Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The following variable holds the full path name of the binary |
| ︙ | ︙ | |||
1874 1875 1876 1877 1878 1879 1880 |
*/
/* ARGSUSED */
char *
TclPrecTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter containing variable. */
| | | 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 |
*/
/* ARGSUSED */
char *
TclPrecTraceProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *name1; /* Name of variable. */
CONST char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
{
CONST char *value;
char *end;
int prec;
|
| ︙ | ︙ | |||
2120 2121 2122 2123 2124 2125 2126 |
TclLooksLikeInt(bytes, length)
register CONST char *bytes; /* Points to first byte of the string. */
int length; /* Number of bytes in the string. If < 0
* bytes up to the first null byte are
* considered (if they may appear in an
* integer). */
{
| | > > > > | < | | | | < | < < | < < < < < | < < < < < | 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 |
TclLooksLikeInt(bytes, length)
register CONST char *bytes; /* Points to first byte of the string. */
int length; /* Number of bytes in the string. If < 0
* bytes up to the first null byte are
* considered (if they may appear in an
* integer). */
{
register CONST char *p;
if ((bytes == NULL) && (length > 0)) {
Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length);
}
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
p = bytes;
while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */
length--; p++;
}
if (length == 0) {
return 0;
}
if ((*p == '+') || (*p == '-')) {
p++; length--;
}
return (0 != TclParseInteger(p, length));
}
/*
*----------------------------------------------------------------------
*
* TclGetIntForIndex --
*
|
| ︙ | ︙ | |||
2193 2194 2195 2196 2197 2198 2199 |
* "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. */
{
char *bytes;
| | | 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 |
* "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. */
{
char *bytes;
int offset;
#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt wideOffset;
#endif
/*
* If the object is already an integer, use it.
*/
|
| ︙ | ︙ | |||
2263 2264 2265 2266 2267 2268 2269 |
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
/*
* Report a parse error.
*/
| | | > > > > > > | 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 |
#endif /* TCL_WIDE_INT_IS_LONG */
} else {
/*
* Report a parse error.
*/
if (interp != NULL) {
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),
"bad index \"", bytes,
"\": must be integer or end?-integer?",
(char *) NULL);
if (!strncmp(bytes, "end-", 3)) {
bytes += 3;
}
|
| ︙ | ︙ | |||
2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 |
/* Check for a string rep of the right form. */
bytes = Tcl_GetStringFromObj(objPtr, &length);
if ((*bytes != 'e') || (strncmp(bytes, "end",
(size_t)((length > 3) ? 3 : length)) != 0)) {
if (interp != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be end?-integer?",
(char*) NULL);
}
return TCL_ERROR;
}
| > | 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 |
/* Check for a string rep of the right form. */
bytes = Tcl_GetStringFromObj(objPtr, &length);
if ((*bytes != 'e') || (strncmp(bytes, "end",
(size_t)((length > 3) ? 3 : length)) != 0)) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be end?-integer?",
(char*) NULL);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 |
}
} else {
/*
* Conversion failed. Report the error.
*/
if (interp != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be integer or end?-integer?",
(char *) NULL);
}
return TCL_ERROR;
}
| > | 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 |
}
} else {
/*
* Conversion failed. Report the error.
*/
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad index \"", bytes,
"\": must be integer or end?-integer?",
(char *) NULL);
}
return TCL_ERROR;
}
|
| ︙ | ︙ |
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 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 |
* 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.38.2.3 2002/08/20 20:25:26 das 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";
static CONST char *isArray = "variable is array";
static CONST char *needArray = "variable isn't array";
static CONST char *noSuchElement = "no such element in array";
static CONST char *danglingElement =
"upvar refers to element in deleted array";
static CONST char *danglingVar =
"upvar refers to variable in deleted namespace";
static CONST char *badNamespace = "parent namespace doesn't exist";
static CONST char *missingName = "missing variable name";
static CONST char *isArrayElement = "name refers to an element in an array";
/*
* Forward references to procedures defined later in this file:
*/
static int CallVarTraces _ANSI_ARGS_((Interp *iPtr, Var *arrayPtr,
Var *varPtr, CONST char *part1, CONST char *part2,
int flags, CONST int leaveErrMsg));
static void CleanupVar _ANSI_ARGS_((Var *varPtr,
Var *arrayPtr));
static void DeleteSearches _ANSI_ARGS_((Var *arrayVarPtr));
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, CONST 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));
/*
* 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,
CONST char *varName, int flags, CONST int create,
CONST char **errMsgPtr, int *indexPtr));
int TclObjUnsetVar2 _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *part1Ptr, CONST char *part2, int flags));
static Tcl_FreeInternalRepProc FreeLocalVarName;
static Tcl_DupInternalRepProc DupLocalVarName;
static Tcl_UpdateStringProc UpdateLocalVarName;
static Tcl_FreeInternalRepProc FreeNsVarName;
static Tcl_DupInternalRepProc DupNsVarName;
static Tcl_FreeInternalRepProc FreeParsedVarName;
static Tcl_DupInternalRepProc DupParsedVarName;
static Tcl_UpdateStringProc UpdateParsedVarName;
/*
* Types of Tcl_Objs used to cache variable lookups.
*
*
* localVarName - INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = pointer to the corresponding Proc
* twoPtrValue.ptr2 = index into locals table
*
* nsVarName - INTERNALREP DEFINITION:
* twoPtrValue.ptr1: pointer to the namespace containing the
* reference
* twoPtrValue.ptr2: pointer to the corresponding Var
*
* parsedVarName - INTERNALREP DEFINITION:
* 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
*/
Tcl_ObjType tclLocalVarNameType = {
"localVarName",
FreeLocalVarName, DupLocalVarName, UpdateLocalVarName, NULL
};
Tcl_ObjType tclNsVarNameType = {
"namespaceVarName",
FreeNsVarName, DupNsVarName, NULL, NULL
};
Tcl_ObjType tclParsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, NULL
};
/*
* Type of Tcl_Objs used to speed up array searches.
*
* INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL
* twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL
*
|
| ︙ | ︙ | |||
81 82 83 84 85 86 87 | /* *---------------------------------------------------------------------- * * TclLookupVar -- * | < | > > > > | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | /* *---------------------------------------------------------------------- * * TclLookupVar -- * * This procedure is used to locate a variable given its name(s). It * has been mostly superseded by TclObjLookupVar, it is now only used * by the string-based interfaces. It is kept in tcl8.4 mainly because * it is in the internal stubs table, so that some extension may be * calling it. * * Results: * The return value is a pointer to the variable structure indicated by * part1 and part2, or NULL if the variable couldn't be found. If the * variable is found, *arrayPtrPtr is filled in with the address of the * variable structure for the array that contains the variable (or NULL * if the variable is a scalar). If the variable can't be found and |
| ︙ | ︙ | |||
111 112 113 114 115 116 117 | * * Side effects: * New hashtable entries may be created if createPart1 or createPart2 * are 1. * *---------------------------------------------------------------------- */ | < | | < < < < < < < < < | < | | | < | < < < | > | > > > | < | > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | > > > > | > > > > > > > > | > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > | > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | | | | < < < | | | | | > > > > > > > > > > > | | | < < | > | < < < | < < > > > > > > > > | < < > < > > > | | | | > | < < | | | | | | | | | | | | | | | | | | | | | | | < | > | | | < | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | | < > > > | | | < < | < > > > > > > > > > > > > | < > > | < > | < > | | | | < | | | < | | | | | | | < | | | | | | | | | < | < < < < < < < | 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 |
*
* Side effects:
* New hashtable entries may be created if createPart1 or createPart2
* are 1.
*
*----------------------------------------------------------------------
*/
Var *
TclLookupVar(interp, part1, part2, flags, msg, createPart1, createPart2,
arrayPtrPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
CONST char *part1; /* If part2 isn't NULL, this is the name of
* an array. Otherwise, this
* is a full variable name that could
* include a parenthesized array element. */
CONST char *part2; /* Name of element within array, or NULL. */
int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* and TCL_LEAVE_ERR_MSG bits matter. */
CONST char *msg; /* Verb to use in error messages, e.g.
* "read" or "set". Only needed if
* TCL_LEAVE_ERR_MSG is set in flags. */
int createPart1; /* If 1, create hash table entry for part 1
* of name, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
int createPart2; /* If 1, create hash table entry for part 2
* of name, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
Var **arrayPtrPtr; /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise
* this is set to NULL. */
{
Var *varPtr;
CONST char *elName; /* Name of array element or NULL; may be
* same as part2, or may be openParen+1. */
int openParen, closeParen;
/* If this procedure parses a name into
* array and index, these are the offsets to
* the parens around the index. Otherwise
* they are -1. */
register CONST char *p;
CONST char *errMsg = NULL;
int index;
#define VAR_NAME_BUF_SIZE 26
char buffer[VAR_NAME_BUF_SIZE];
char *newVarName = buffer;
varPtr = NULL;
*arrayPtrPtr = NULL;
openParen = closeParen = -1;
/*
* Parse part1 into array name and index.
* Always check if part1 is an array element name and allow it only if
* part2 is not given.
* (if one does not care about creating array elements that can't be used
* from tcl, and prefer slightly better performance, one can put
* the following in an if (part2 == NULL) { ... } block and remove
* the part2's test and error reporting or move that code in array set)
*/
elName = part2;
for (p = part1; *p ; p++) {
if (*p == '(') {
openParen = p - part1;
do {
p++;
} while (*p != '\0');
p--;
if (*p == ')') {
if (part2 != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, msg, needArray);
}
return NULL;
}
closeParen = p - part1;
} else {
openParen = -1;
}
break;
}
}
if (openParen != -1) {
if (closeParen >= VAR_NAME_BUF_SIZE) {
newVarName = ckalloc((unsigned int) (closeParen+1));
}
memcpy(newVarName, part1, (unsigned int) closeParen);
newVarName[openParen] = '\0';
newVarName[closeParen] = '\0';
part1 = newVarName;
elName = newVarName + openParen + 1;
}
varPtr = TclLookupSimpleVar(interp, part1, flags,
createPart1, &errMsg, &index);
if (varPtr == NULL) {
if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
VarErrMsg(interp, part1, elName, msg, errMsg);
}
} else {
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (elName != NULL) {
*arrayPtrPtr = varPtr;
varPtr = TclLookupArrayElement(interp, part1, elName, flags,
msg, createPart1, createPart2, varPtr);
}
}
if (newVarName != buffer) {
ckfree(newVarName);
}
return varPtr;
#undef VAR_NAME_BUF_SIZE
}
/*
*----------------------------------------------------------------------
*
* TclObjLookupVar --
*
* This procedure is used by virtually all of the variable code to
* locate a variable given its name(s). The parsing into array/element
* components and (if possible) the lookup results are cached in
* part1Ptr, which is converted to one of the varNameTypes.
*
* Results:
* The return value is a pointer to the variable structure indicated by
* part1Ptr and part2, or NULL if the variable couldn't be found. If
* the variable is found, *arrayPtrPtr is filled with the address of the
* variable structure for the array that contains the variable (or NULL
* if the variable is a scalar). If the variable can't be found and
* either createPart1 or createPart2 are 1, a new as-yet-undefined
* (VAR_UNDEFINED) variable structure is created, entered into a hash
* table, and returned.
*
* If the variable isn't found and creation wasn't specified, or some
* other error occurs, NULL is returned and an error message is left in
* the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* Note: it's possible for the variable returned to be VAR_UNDEFINED
* even if createPart1 or createPart2 are 1 (these only cause the hash
* table entry or array to be created). For example, the variable might
* be a global that has been unset but is still referenced by a
* procedure, or a variable that has been unset but it only being kept
* in existence (if VAR_UNDEFINED) by a trace.
*
* Side effects:
* New hashtable entries may be created if createPart1 or createPart2
* are 1.
* The object part1Ptr is converted to one of tclLocalVarNameType,
* tclNsVarNameType or tclParsedVarNameType and caches as much of the
* lookup as it can.
*
*----------------------------------------------------------------------
*/
Var *
TclObjLookupVar(interp, part1Ptr, part2, flags, msg, createPart1, createPart2,
arrayPtrPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
register Tcl_Obj *part1Ptr; /* If part2 isn't NULL, this is the name
* of an array. Otherwise, this is a full
* variable name that could include a parenthesized
* array element. */
CONST char *part2; /* Name of element within array, or NULL. */
int flags; /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* and TCL_LEAVE_ERR_MSG bits matter. */
CONST char *msg; /* Verb to use in error messages, e.g.
* "read" or "set". Only needed if
* TCL_LEAVE_ERR_MSG is set in flags. */
CONST int createPart1; /* If 1, create hash table entry for part 1
* of name, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
CONST int createPart2; /* If 1, create hash table entry for part 2
* of name, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
Var **arrayPtrPtr; /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise
* this is set to NULL. */
{
Interp *iPtr = (Interp *) interp;
register Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
char *part1;
int index, len1, len2;
int parsed = 0;
Tcl_Obj *objPtr;
Tcl_ObjType *typePtr = part1Ptr->typePtr;
CONST char *errMsg = NULL;
CallFrame *varFramePtr = iPtr->varFramePtr;
Namespace *nsPtr;
/*
* If part1Ptr is a tclParsedVarNameType, separate it into the
* pre-parsed parts.
*/
*arrayPtrPtr = NULL;
if (typePtr == &tclParsedVarNameType) {
if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) {
if (part2 != NULL) {
/*
* ERROR: part1Ptr is already an array element, cannot
* specify a part2.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
part1 = TclGetString(part1Ptr);
VarErrMsg(interp, part1, part2, msg, needArray);
}
return NULL;
}
part2 = (char *) part1Ptr->internalRep.twoPtrValue.ptr2;
part1Ptr = (Tcl_Obj *) part1Ptr->internalRep.twoPtrValue.ptr1;
typePtr = part1Ptr->typePtr;
}
parsed = 1;
}
part1 = Tcl_GetStringFromObj(part1Ptr, &len1);
nsPtr = ((varFramePtr == NULL)? iPtr->globalNsPtr : varFramePtr->nsPtr);
if (nsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
goto doParse;
}
if (typePtr == &tclLocalVarNameType) {
Proc *procPtr = (Proc *) part1Ptr->internalRep.twoPtrValue.ptr1;
int localIndex = (int) part1Ptr->internalRep.twoPtrValue.ptr2;
int useLocal;
useLocal = ((varFramePtr != NULL) && varFramePtr->isProcCallFrame
&& !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)));
if (useLocal && (procPtr == varFramePtr->procPtr)) {
/*
* part1Ptr points to an indexed local variable of the
* correct procedure: use the cached value.
*/
varPtr = &(varFramePtr->compiledLocals[localIndex]);
goto donePart1;
}
goto doneParsing;
} else if (typePtr == &tclNsVarNameType) {
Namespace *cachedNsPtr;
int useGlobal, useReference;
varPtr = (Var *) part1Ptr->internalRep.twoPtrValue.ptr2;
cachedNsPtr = (Namespace *) part1Ptr->internalRep.twoPtrValue.ptr1;
useGlobal = (cachedNsPtr == iPtr->globalNsPtr)
&& ((flags & TCL_GLOBAL_ONLY)
|| ((*part1 == ':') && (*(part1+1) == ':'))
|| (varFramePtr == NULL)
|| (!varFramePtr->isProcCallFrame
&& (nsPtr == iPtr->globalNsPtr)));
useReference = useGlobal || ((cachedNsPtr == nsPtr)
&& ((flags & TCL_NAMESPACE_ONLY)
|| (varFramePtr && !varFramePtr->isProcCallFrame
&& !(flags & TCL_GLOBAL_ONLY)
/* careful: an undefined ns variable could
* be hiding a valid global reference. */
&& !(varPtr->flags & VAR_UNDEFINED))));
if (useReference && (varPtr->hPtr != NULL)) {
/*
* A straight global or namespace reference, use it. It isn't
* so simple to deal with 'implicit' namespace references, i.e.,
* those where the reference could be to either a namespace
* or a global variable. Those we lookup again.
*
* If (varPtr->hPtr == NULL), this might be a reference to a
* variable in a deleted namespace, kept alive by e.g. part1Ptr.
* We could conceivably be so unlucky that a new namespace was
* created at the same address as the deleted one, so to be
* safe we test for a valid hPtr.
*/
goto donePart1;
}
goto doneParsing;
}
doParse:
if (!parsed && (*(part1 + len1 - 1) == ')')) {
/*
* part1Ptr is possibly an unparsed array element.
*/
register int i;
char *newPart2;
len2 = -1;
for (i = 0; i < len1; i++) {
if (*(part1 + i) == '(') {
if (part2 != NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, msg, needArray);
}
}
/*
* part1Ptr points to an array element; first copy
* the element name to a new string part2.
*/
part2 = part1 + i + 1;
len2 = len1 - i - 2;
len1 = i;
newPart2 = ckalloc((unsigned int) (len2+1));
memcpy(newPart2, part2, (unsigned int) len2);
*(newPart2+len2) = '\0';
part2 = newPart2;
/*
* Free the internal rep of the original part1Ptr, now
* renamed objPtr, and set it to tclParsedVarNameType.
*/
objPtr = part1Ptr;
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
typePtr->freeIntRepProc(objPtr);
}
objPtr->typePtr = &tclParsedVarNameType;
/*
* Define a new string object to hold the new part1Ptr, i.e.,
* the array name. Set the internal rep of objPtr, reset
* typePtr and part1 to contain the references to the
* array name.
*/
part1Ptr = Tcl_NewStringObj(part1, len1);
Tcl_IncrRefCount(part1Ptr);
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) part1Ptr;
objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) part2;
typePtr = part1Ptr->typePtr;
part1 = TclGetString(part1Ptr);
break;
}
}
}
doneParsing:
/*
* part1Ptr is not an array element; look it up, and convert
* it to one of the cached types if possible.
*/
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
typePtr->freeIntRepProc(part1Ptr);
part1Ptr->typePtr = NULL;
}
varPtr = TclLookupSimpleVar(interp, part1, flags,
createPart1, &errMsg, &index);
if (varPtr == NULL) {
if ((errMsg != NULL) && (flags & TCL_LEAVE_ERR_MSG)) {
VarErrMsg(interp, part1, part2, msg, errMsg);
}
return NULL;
}
/*
* Cache the newly found variable if possible.
*/
if (index >= 0) {
/*
* An indexed local variable.
*/
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;
}
donePart1:
#if 0
if (varPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
part1 = TclGetString(part1Ptr);
VarErrMsg(interp, part1, part2, msg,
"Cached variable reference is NULL.");
}
return NULL;
}
#endif
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (part2 != NULL) {
/*
* Array element sought: look it up.
*/
part1 = TclGetString(part1Ptr);
*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.
*
* Results:
* The return value is a pointer to the variable structure indicated by
* varName, or NULL if the variable couldn't be found. If the variable
* can't be found and create is 1, a new as-yet-undefined (VAR_UNDEFINED)
* variable structure is created, entered into a hash table, and returned.
*
* If the current CallFrame corresponds to a proc and the variable found is
* one of the compiledLocals, its index is placed in *indexPtr. Otherwise,
* *indexPtr will be set to (according to the needs of TclObjLookupVar):
* -1 a global reference
* -2 a reference to a namespace variable
* -3 a non-cachable reference, i.e., one of:
* . non-indexed local var
* . a reference of unknown origin;
* . resolution by a namespace or interp resolver
*
* If the variable isn't found and creation wasn't specified, or some
* other error occurs, NULL is returned and the corresponding error
* message is left in *errMsgPtr.
*
* Note: it's possible for the variable returned to be VAR_UNDEFINED
* even if create is 1 (this only causes the hash table entry to be
* created). For example, the variable might be a global that has been
* unset but is still referenced by a procedure, or a variable that has
* been unset but it only being kept in existence (if VAR_UNDEFINED) by
* a trace.
*
* Side effects:
* A new hashtable entry may be created if create is 1.
*
*----------------------------------------------------------------------
*/
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,
* 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;
CallFrame *varFramePtr = iPtr->varFramePtr;
/* Points to the procedure call frame whose
* variables are currently in use. Same as
* the current procedure's frame, if any,
* unless an "uplevel" is executing. */
Tcl_HashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
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.
*/
if ((flags & TCL_GLOBAL_ONLY) || iPtr->varFramePtr == NULL) {
cxtNsPtr = iPtr->globalNsPtr;
} else {
cxtNsPtr = iPtr->varFramePtr->nsPtr;
}
if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->varResProc) {
result = (*cxtNsPtr->varResProc)(interp, varName,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
} else {
result = TCL_CONTINUE;
}
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->varResProc) {
result = (*resPtr->varResProc)(interp, varName,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
varPtr = (Var *) var;
return varPtr;
} else if (result != TCL_CONTINUE) {
return NULL;
}
}
/*
* Look up varName. Look it up as either a namespace variable or as a
* local variable in a procedure call frame (varFramePtr).
* Interpret varName as a namespace variable if:
* 1) so requested by a TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY flag,
* 2) there is no active frame (we're at the global :: scope),
* 3) the active frame was pushed to define the namespace context
* for a "namespace eval" or "namespace inscope" command,
* 4) the name has namespace qualifiers ("::"s).
* Otherwise, if varName is a local variable, search first in the
* frame's array of compiler-allocated local variables, then in its
* hashtable for runtime-created local variables.
*
* If create and the variable isn't found, create the variable and,
* if necessary, create varFramePtr's local var hashtable.
*/
if (((flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) != 0)
|| (varFramePtr == NULL)
|| !varFramePtr->isProcCallFrame
|| (strstr(varName, "::") != NULL)) {
CONST char *tail;
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;
} else 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);
if (var != (Tcl_Var) NULL) {
varPtr = (Var *) var;
}
if (varPtr == NULL) {
if (create) { /* var wasn't found so create it */
TclGetNamespaceForQualName(interp, varName, cxtNsPtr,
flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail);
if (varNsPtr == NULL) {
*errMsgPtr = badNamespace;
return NULL;
}
if (tail == NULL) {
*errMsgPtr = missingName;
return NULL;
}
hPtr = Tcl_CreateHashEntry(&varNsPtr->varTable, tail, &new);
varPtr = NewVar();
Tcl_SetHashValue(hPtr, varPtr);
varPtr->hPtr = hPtr;
varPtr->nsPtr = varNsPtr;
if ((lookGlobal) || (varNsPtr == NULL)) {
/*
* The variable was created starting from the global
* namespace: a global reference is returned even if
* it wasn't explicitly requested.
*/
*indexPtr = -1;
} else {
*indexPtr = -2;
}
} else { /* var wasn't found and not to create it */
*errMsgPtr = noSuchVar;
return NULL;
}
}
} else { /* local var: look in frame varFramePtr */
Proc *procPtr = varFramePtr->procPtr;
int localCt = procPtr->numCompiledLocals;
CompiledLocal *localPtr = procPtr->firstLocalPtr;
Var *localVarPtr = varFramePtr->compiledLocals;
int varNameLen = strlen(varName);
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
register char *localName = localVarPtr->name;
if ((varName[0] == localName[0])
&& (varNameLen == localPtr->nameLength)
&& (strcmp(varName, localName) == 0)) {
*indexPtr = i;
return localVarPtr;
}
}
localVarPtr++;
localPtr = localPtr->nextPtr;
}
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
tablePtr = (Tcl_HashTable *)
ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tablePtr, TCL_STRING_KEYS);
varFramePtr->varTablePtr = tablePtr;
}
hPtr = Tcl_CreateHashEntry(tablePtr, varName, &new);
if (new) {
varPtr = NewVar();
Tcl_SetHashValue(hPtr, varPtr);
varPtr->hPtr = hPtr;
varPtr->nsPtr = NULL; /* a local variable */
} else {
varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
} else {
hPtr = NULL;
if (tablePtr != NULL) {
hPtr = Tcl_FindHashEntry(tablePtr, varName);
}
if (hPtr == NULL) {
*errMsgPtr = noSuchVar;
return NULL;
}
varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
}
return varPtr;
}
/*
*----------------------------------------------------------------------
*
* TclLookupArrayElement --
*
* This procedure is used to locate a variable which is in an array's
* hashtable given a pointer to the array's Var structure and the
* element's name.
*
* Results:
* The return value is a pointer to the variable structure , or NULL if
* the variable couldn't be found.
*
* If arrayPtr points to a variable that isn't an array and createPart1
* is 1, the corresponding variable will be converted to an array.
* Otherwise, NULL is returned and an error message is left in
* the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* If the variable is not found and createPart2 is 1, the variable is
* created. Otherwise, NULL is returned and an error message is left in
* the interp's result if TCL_LEAVE_ERR_MSG is set in flags.
*
* Note: it's possible for the variable returned to be VAR_UNDEFINED
* even if createPart1 or createPart2 are 1 (these only cause the hash
* table entry or array to be created). For example, the variable might
* be a global that has been unset but is still referenced by a
* procedure, or a variable that has been unset but it only being kept
* in existence (if VAR_UNDEFINED) by a trace.
*
* Side effects:
* The variable at arrayPtr may be converted to be an array if
* createPart1 is 1. A new hashtable entry may be created if createPart2
* is 1.
*
*----------------------------------------------------------------------
*/
Var *
TclLookupArrayElement(interp, arrayName, elName, flags, msg, createArray, createElem, arrayPtr)
Tcl_Interp *interp; /* Interpreter to use for lookup. */
CONST char *arrayName; /* This is the name of the array. */
CONST char *elName; /* Name of element within array. */
CONST int flags; /* Only TCL_LEAVE_ERR_MSG bit matters. */
CONST char *msg; /* Verb to use in error messages, e.g.
* "read" or "set". Only needed if
* TCL_LEAVE_ERR_MSG is set in flags. */
CONST int createArray; /* If 1, transform arrayName to be an array
* if it isn't one yet and the transformation
* is possible. If 0, return error if it
* isn't already an array. */
CONST int createElem; /* If 1, create hash table entry for the
* element, if it doesn't already exist. If
* 0, return error if it doesn't exist. */
Var *arrayPtr; /* Pointer to the array's Var structure. */
{
Tcl_HashEntry *hPtr;
int new;
Var *varPtr;
/*
* We're dealing with an array element. Make sure the variable is an
* array and look up the element (create the element if desired).
*/
if (TclIsVarUndefined(arrayPtr) && !TclIsVarArrayElement(arrayPtr)) {
if (!createArray) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elName, msg, noSuchVar);
}
return NULL;
}
/*
* Make sure we are not resurrecting a namespace variable from a
* deleted namespace!
*/
if ((arrayPtr->flags & VAR_IN_HASHTABLE) && (arrayPtr->hPtr == NULL)) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elName, msg, danglingVar);
}
return NULL;
}
TclSetVarArray(arrayPtr);
TclClearVarUndefined(arrayPtr);
arrayPtr->value.tablePtr =
(Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(arrayPtr->value.tablePtr, TCL_STRING_KEYS);
} else if (!TclIsVarArray(arrayPtr)) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elName, msg, needArray);
}
return NULL;
}
if (createElem) {
hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elName, &new);
if (new) {
if (arrayPtr->searchPtr != NULL) {
DeleteSearches(arrayPtr);
}
varPtr = NewVar();
Tcl_SetHashValue(hPtr, varPtr);
varPtr->hPtr = hPtr;
varPtr->nsPtr = arrayPtr->nsPtr;
TclSetVarArrayElement(varPtr);
}
} else {
hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elName);
if (hPtr == NULL) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, arrayName, elName, msg, noSuchElement);
}
return NULL;
}
}
return (Var *) Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVar --
*
|
| ︙ | ︙ | |||
476 477 478 479 480 481 482 |
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetVar(interp, varName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
| | | 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 |
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetVar(interp, varName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *varName; /* Name of a variable in interp. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
* bits. */
{
return Tcl_GetVar2(interp, varName, (char *) NULL, flags);
}
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 |
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetVar2(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*----------------------------------------------------------------------
*/
CONST char *
Tcl_GetVar2(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
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. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY and TCL_LEAVE_ERR_MSG
* bits. */
{
Tcl_Obj *objPtr;
objPtr = Tcl_GetVar2Ex(interp, part1, part2, flags);
if (objPtr == NULL) {
return NULL;
}
return TclGetString(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVar2Ex --
*
* Return the value of a Tcl variable as a Tcl object, given a
* two-part name consisting of array name and element within array.
*
* Results:
* The return value points to the current object value of the variable
* given by part1Ptr and part2Ptr. If the specified variable doesn't
* exist, or if there is a clash in array usage, then NULL is returned
* and a message will be left in the interpreter's result if the
* TCL_LEAVE_ERR_MSG flag is set.
*
* Side effects:
* The ref count for the returned object is _not_ incremented to
* reflect the returned reference; if you want to keep a reference to
* the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetVar2Ex(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
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. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* and TCL_LEAVE_ERR_MSG bits. */
{
Var *varPtr, *arrayPtr;
/*
* We need a special flag check to see if we want to create part 1,
* because commands like lappend require read traces to trigger for
* previously non-existent values.
*/
varPtr = TclLookupVar(interp, part1, part2, flags, "read",
/*createPart1*/ (flags & TCL_TRACE_READS),
/*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ObjGetVar2 --
*
* Return the value of a Tcl variable as a Tcl object, given a
* two-part name consisting of array name and element within array.
|
| ︙ | ︙ | |||
563 564 565 566 567 568 569 570 571 572 |
* name of a variable. */
register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG bits. */
{
char *part1, *part2;
part1 = Tcl_GetString(part1Ptr);
| > < | | > > > > > > > > > | | | | | < > > | | | < | > > > | | < < | < < < < < < < < < < < < | | 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 |
* name of a variable. */
register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG bits. */
{
Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = Tcl_GetString(part1Ptr);
part2 = ((part2Ptr == NULL) ? NULL : Tcl_GetString(part2Ptr));
/*
* We need a special flag check to see if we want to create part 1,
* because commands like lappend require read traces to trigger for
* previously non-existent values.
*/
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
/*createPart1*/ (flags & TCL_TRACE_READS),
/*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
return NULL;
}
return TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
}
/*
*----------------------------------------------------------------------
*
* TclPtrGetVar --
*
* Return the value of a Tcl variable as a Tcl object, given the
* pointers to the variable's (and possibly containing array's)
* VAR structure.
*
* Results:
* The return value points to the current object value of the variable
* given by varPtr. If the specified variable doesn't exist, or if there
* is a clash in array usage, then NULL is returned and a message will be
* left in the interpreter's result if the TCL_LEAVE_ERR_MSG flag is set.
*
* Side effects:
* The ref count for the returned object is _not_ incremented to
* reflect the returned reference; if you want to keep a reference to
* the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
register Var *varPtr; /* The variable to be read.*/
Var *arrayPtr; /* NULL for scalar variables, pointer to
* the containing array otherwise. */
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. */
CONST int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* and TCL_LEAVE_ERR_MSG bits. */
{
Interp *iPtr = (Interp *) interp;
CONST char *msg;
/*
* Invoke any traces that have been set for the variable.
*/
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
(flags & (TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY))
| TCL_TRACE_READS, (flags & TCL_LEAVE_ERR_MSG))) {
goto errorReturn;
}
}
/*
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
* it, then free up the relevant structures and hash table entries.
*/
errorReturn:
if (TclIsVarUndefined(varPtr)) {
CleanupVar(varPtr, arrayPtr);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 |
* it, then free up the relevant structures and hash table entries.
*/
errorReturn:
if (TclIsVarUndefined(varPtr)) {
CleanupVar(varPtr, arrayPtr);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjCmd --
|
| ︙ | ︙ | |||
1018 1019 1020 1021 1022 1023 1024 |
*----------------------------------------------------------------------
*/
CONST char *
Tcl_SetVar(interp, varName, newValue, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
| | | 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 |
*----------------------------------------------------------------------
*/
CONST char *
Tcl_SetVar(interp, varName, newValue, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *varName; /* Name of a variable in interp. */
CONST char *newValue; /* New value for varName. */
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
return Tcl_SetVar2(interp, varName, (char *) NULL, newValue, flags);
|
| ︙ | ︙ | |||
1059 1060 1061 1062 1063 1064 1065 |
*----------------------------------------------------------------------
*/
CONST char *
Tcl_SetVar2(interp, part1, part2, newValue, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
| | | 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 |
*----------------------------------------------------------------------
*/
CONST char *
Tcl_SetVar2(interp, part1, part2, newValue, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
CONST char *part1; /* If part2 is NULL, this is name of scalar
* variable. Otherwise it is the name of
* an array. */
CONST char *part2; /* Name of an element within an array, or
* NULL. */
CONST char *newValue; /* New value for variable. */
int flags; /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY,
|
| ︙ | ︙ | |||
1089 1090 1091 1092 1093 1094 1095 |
Tcl_DecrRefCount(valuePtr); /* done with the object */
if (varValuePtr == NULL) {
return NULL;
}
return TclGetString(varValuePtr);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 |
Tcl_DecrRefCount(valuePtr); /* done with the object */
if (varValuePtr == NULL) {
return NULL;
}
return TclGetString(varValuePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetVar2Ex --
*
* Given a two-part variable name, which may refer either to a scalar
|
| ︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
| | < | < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_SetVar2Ex(interp, part1, part2, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
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. */
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,
newValuePtr, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ObjSetVar2 --
*
* This function is the same as Tcl_SetVar2Ex above, except the
* variable names are passed in Tcl object instead of strings.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the write operation was disallowed because an array was
* expected but not found (or vice versa), then NULL is returned; if
* the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
* be left in the interpreter's result. Note that the returned object
* may not be the same one referenced by newValuePtr; this is because
* variable traces may modify the variable's value.
*
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjSetVar2(interp, part1Ptr, part2Ptr, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
register Tcl_Obj *part1Ptr; /* Points to an object holding the name of
* an array (if part2 is non-NULL) or the
* name of a variable. */
register Tcl_Obj *part2Ptr; /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *newValuePtr; /* New value for variable. */
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;
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,
newValuePtr, flags);
}
/*
*----------------------------------------------------------------------
*
* TclPtrSetVar --
*
* This function is the same as Tcl_SetVar2Ex above, except that
* it requires pointers to the variable's Var structs in addition
* to the variable names.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the write operation was disallowed because an array was
* expected but not found (or vice versa), then NULL is returned; if
* the TCL_LEAVE_ERR_MSG flag is set, then an explanatory message will
* be left in the interpreter's result. Note that the returned object
* may not be the same one referenced by newValuePtr; this is because
* variable traces may modify the variable's value.
*
* Side effects:
* The value of the given variable is set. If either the array or the
* entry didn't exist then a new variable is created.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2, newValuePtr, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be looked up. */
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;
/*
* If the variable is in a hashtable and its hPtr field is NULL, then we
* may have an upvar to an array element where the array was deleted
* or an upvar to a namespace variable whose namespace was deleted.
* Generate an error (allowing the variable to be reset would screw up
* our storage allocation and is meaningless anyway).
|
| ︙ | ︙ | |||
1239 1240 1241 1242 1243 1244 1245 |
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, "set", isArray);
}
return NULL;
}
/*
| | | < < > > > > > > > > | 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 |
if (flags & TCL_LEAVE_ERR_MSG) {
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 when lappending.
*/
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".
|
| ︙ | ︙ | |||
1318 1319 1320 1321 1322 1323 1324 |
/*
* Invoke any write traces for the variable.
*/
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
| | | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 |
/*
* Invoke any write traces for the variable.
*/
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_WRITES, (flags & TCL_LEAVE_ERR_MSG))) {
goto cleanup;
}
}
/*
|
| ︙ | ︙ | |||
1351 1352 1353 1354 1355 1356 1357 |
* free up the relevant structures and hash table entries.
*/
cleanup:
if (TclIsVarUndefined(varPtr)) {
CleanupVar(varPtr, arrayPtr);
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 |
* free up the relevant structures and hash table entries.
*/
cleanup:
if (TclIsVarUndefined(varPtr)) {
CleanupVar(varPtr, arrayPtr);
}
return resultPtr;
}
/*
*----------------------------------------------------------------------
*
* TclIncrVar2 --
|
| ︙ | ︙ | |||
1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 |
* part1Ptr. */
long incrAmount; /* Amount to be added to variable. */
int flags; /* Various flags that tell how to incr value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
register Tcl_Obj *varValuePtr;
int createdNewObj; /* Set 1 if var's value object is shared
* so we must increment a copy (i.e. copy
* on write). */
long i;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
* part1Ptr. */
long incrAmount; /* Amount to be added to variable. */
int flags; /* Various flags that tell how to incr value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
Var *varPtr, *arrayPtr;
char *part1, *part2;
part1 = TclGetString(part1Ptr);
part2 = ((part2Ptr == NULL)? NULL : TclGetString(part2Ptr));
varPtr = TclObjLookupVar(interp, part1Ptr, part2, flags, "read",
0, 1, &arrayPtr);
if (varPtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
return NULL;
}
return TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2,
incrAmount, flags);
}
/*
*----------------------------------------------------------------------
*
* TclPtrIncrVar --
*
* Given the pointers to a variable and possible containing array,
* increment the Tcl object value of the variable by a specified
* amount.
*
* Results:
* Returns a pointer to the Tcl_Obj holding the new value of the
* variable. If the specified variable doesn't exist, or there is a
* clash in array usage, or an error occurs while executing variable
* traces, then NULL is returned and a message will be left in
* the interpreter's result.
*
* Side effects:
* The value of the given variable is incremented by the specified
* amount. If either the array or the entry didn't exist then a new
* variable is created. The ref count for the returned object is _not_
* incremented to reflect the returned reference; if you want to keep a
* reference to the object you must increment its ref count yourself.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrIncrVar(interp, varPtr, arrayPtr, part1, part2, incrAmount, flags)
Tcl_Interp *interp; /* Command interpreter in which variable is
* to be found. */
Var *varPtr;
Var *arrayPtr;
CONST char *part1; /* Points to an object holding the name of
* an array (if part2 is non-NULL) or the
* name of a variable. */
CONST char *part2; /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
CONST long incrAmount; /* Amount to be added to variable. */
CONST int flags; /* Various flags that tell how to incr value:
* any of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY, TCL_APPEND_VALUE,
* TCL_LIST_ELEMENT, TCL_LEAVE_ERR_MSG. */
{
register Tcl_Obj *varValuePtr;
int createdNewObj; /* Set 1 if var's value object is shared
* so we must increment a copy (i.e. copy
* on write). */
long i;
varValuePtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, part2, flags);
if (varValuePtr == NULL) {
Tcl_AddObjErrorInfo(interp,
"\n (reading value of variable to increment)", -1);
return NULL;
}
/*
|
| ︙ | ︙ | |||
1959 1960 1961 1962 1963 1964 1965 |
}
#endif
/*
* Store the variable's new value and run any write traces.
*/
| < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 |
}
#endif
/*
* Store the variable's new value and run any write traces.
*/
return TclPtrSetVar(interp, varPtr, arrayPtr, part1, part2,
varValuePtr, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnsetVar --
*
|
| ︙ | ︙ | |||
2195 2196 2197 2198 2199 2200 2201 |
*----------------------------------------------------------------------
*/
int
Tcl_UnsetVar(interp, varName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
| | | 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 |
*----------------------------------------------------------------------
*/
int
Tcl_UnsetVar(interp, varName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *varName; /* Name of a variable in interp. May be
* either a scalar name or an array name
* or an element in an array. */
int flags; /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
* TCL_LEAVE_ERR_MSG. */
{
return Tcl_UnsetVar2(interp, varName, (char *) NULL, flags);
|
| ︙ | ︙ | |||
2230 2231 2232 2233 2234 2235 2236 |
*----------------------------------------------------------------------
*/
int
Tcl_UnsetVar2(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_UnsetVar2(interp, part1, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *part1; /* 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. */
{
int result;
Tcl_Obj *part1Ptr;
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
result = TclObjUnsetVar2(interp, part1Ptr, part2, flags);
TclDecrRefCount(part1Ptr);
return result;
}
/*
*----------------------------------------------------------------------
*
* TclObjUnsetVar2 --
*
* Delete a variable, given a 2-object name.
*
* Results:
* Returns TCL_OK if the variable was successfully deleted, TCL_ERROR
* if the variable can't be unset. In the event of an error,
* if the TCL_LEAVE_ERR_MSG flag is set then an error message
* is left in the interp's result.
*
* Side effects:
* If part1ptr and part2Ptr indicate a local or global variable in interp,
* it is deleted. If part1Ptr is an array name and part2Ptr is NULL, then
* the whole array is deleted.
*
*----------------------------------------------------------------------
*/
int
TclObjUnsetVar2(interp, part1Ptr, part2, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* 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 dummyVar;
Var *varPtr, *dummyVarPtr;
Interp *iPtr = (Interp *) interp;
Var *arrayPtr;
ActiveVarTrace *activePtr;
Tcl_Obj *objPtr;
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);
if ((arrayPtr != NULL) && (arrayPtr->searchPtr != NULL)) {
DeleteSearches(arrayPtr);
}
/*
|
| ︙ | ︙ | |||
2279 2280 2281 2282 2283 2284 2285 |
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
/*
* Call trace procedures for the variable being deleted. Then delete
* its traces. Be sure to abort any other traces for the variable
* that are still pending. Special tricks:
| | | | | 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 |
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
/*
* Call trace procedures for the variable being deleted. Then delete
* its traces. Be sure to abort any other traces for the variable
* that are still pending. Special tricks:
* 1. We need to increment varPtr's refCount around this: CallVarTraces
* 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))) {
varPtr->refCount++;
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;
}
}
varPtr->refCount--;
}
|
| ︙ | ︙ | |||
2329 2330 2331 2332 2333 2334 2335 | * * Bumping the count can lead to the odd situation that elements of the * array are being deleted when the array still exists, but since the * array is about to be removed anyway, that shouldn't really matter. */ varPtr->refCount++; DeleteArray(iPtr, part1, dummyVarPtr, | | > | 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 |
*
* Bumping the count can lead to the odd situation that elements of the
* array are being deleted when the array still exists, but since the
* array is about to be removed anyway, that shouldn't really matter.
*/
varPtr->refCount++;
DeleteArray(iPtr, part1, dummyVarPtr,
(flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY))
| TCL_TRACE_UNSETS);
/* Decr ref count */
varPtr->refCount--;
}
if (TclIsVarScalar(dummyVarPtr)
&& (dummyVarPtr->value.objPtr != NULL)) {
objPtr = dummyVarPtr->value.objPtr;
TclDecrRefCount(objPtr);
|
| ︙ | ︙ | |||
2395 2396 2397 2398 2399 2400 2401 |
*----------------------------------------------------------------------
*/
int
Tcl_TraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
| | | 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 |
*----------------------------------------------------------------------
*/
int
Tcl_TraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
CONST char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure to call when specified ops are
* invoked upon varName. */
|
| ︙ | ︙ | |||
2434 2435 2436 2437 2438 2439 2440 |
*----------------------------------------------------------------------
*/
int
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
| | | 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 |
*----------------------------------------------------------------------
*/
int
Tcl_TraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter in which variable is
* to be traced. */
CONST char *part1; /* Name of scalar variable or array. */
CONST char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed collection of bits, including any
* of TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
* and TCL_NAMESPACE_ONLY. */
|
| ︙ | ︙ | |||
2512 2513 2514 2515 2516 2517 2518 |
*
*----------------------------------------------------------------------
*/
void
Tcl_UntraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
| | | 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 |
*
*----------------------------------------------------------------------
*/
void
Tcl_UntraceVar(interp, varName, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed collection of bits describing
* current trace, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY
* and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
|
| ︙ | ︙ | |||
2546 2547 2548 2549 2550 2551 2552 |
*
*----------------------------------------------------------------------
*/
void
Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
| | | 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 |
*
*----------------------------------------------------------------------
*/
void
Tcl_UntraceVar2(interp, part1, part2, flags, proc, clientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *part1; /* Name of variable or array. */
CONST char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed collection of bits describing
* current trace, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY,
|
| ︙ | ︙ | |||
2602 2603 2604 2605 2606 2607 2608 |
break;
}
}
/*
* The code below makes it possible to delete traces while traces
* are active: it makes sure that the deleted trace won't be
| | | | 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 |
break;
}
}
/*
* 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 CallVarTraces.
*/
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->nextTracePtr == tracePtr) {
activePtr->nextTracePtr = tracePtr->nextPtr;
}
}
if (prevPtr == NULL) {
varPtr->tracePtr = tracePtr->nextPtr;
|
| ︙ | ︙ | |||
2657 2658 2659 2660 2661 2662 2663 |
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
| | | 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 |
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *varName; /* Name of variable; may end with "(index)"
* to signify an array reference. */
int flags; /* OR-ed combo or TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY (can be 0). */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData prevClientData; /* If non-NULL, gives last value returned
* by this procedure, so this call will
* return the next trace after that one.
|
| ︙ | ︙ | |||
2692 2693 2694 2695 2696 2697 2698 |
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
| | | 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_VarTraceInfo2(interp, part1, part2, flags, proc, prevClientData)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST char *part1; /* Name of variable or array. */
CONST char *part2; /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
int flags; /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc; /* Procedure assocated with trace. */
ClientData prevClientData; /* If non-NULL, gives last value returned
|
| ︙ | ︙ | |||
2800 2801 2802 2803 2804 2805 2806 |
}
if (strcmp("--", name) == 0) {
i++;
}
}
for (; i < objc; i++) {
| < | | 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 |
}
if (strcmp("--", name) == 0) {
i++;
}
}
for (; i < objc; i++) {
if ((TclObjUnsetVar2(interp, objv[i], NULL, flags) != TCL_OK)
&& (flags == TCL_LEAVE_ERR_MSG)) {
return TCL_ERROR;
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 |
int
Tcl_AppendObjCmd(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 *varValuePtr = NULL;
/* Initialized to avoid compiler
* warning. */
int i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
return TCL_ERROR;
}
if (objc == 2) {
varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
} else {
| > > > > > > > > > > | > > > > > > | > | | 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 |
int
Tcl_AppendObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Var *varPtr, *arrayPtr;
char *part1;
register Tcl_Obj *varValuePtr = NULL;
/* Initialized to avoid compiler
* warning. */
int i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value value ...?");
return TCL_ERROR;
}
if (objc == 2) {
varValuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG);
if (varValuePtr == NULL) {
return TCL_ERROR;
}
} else {
varPtr = TclObjLookupVar(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
part1 = TclGetString(objv[1]);
if (varPtr == NULL) {
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
/*
* Note that we do not need to increase the refCount of
* the Var pointers: should a trace delete the variable,
* the return value of TclPtrSetVar will be NULL, and we
* will not access the variable again.
*/
varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, part1, NULL,
objv[i], (TCL_APPEND_VALUE | TCL_LEAVE_ERR_MSG));
if (varValuePtr == NULL) {
return TCL_ERROR;
}
}
}
Tcl_SetObjResult(interp, varValuePtr);
return TCL_OK;
|
| ︙ | ︙ | |||
2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 |
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, createVar, i, j;
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);
| > > | 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 |
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, createVar, 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);
|
| ︙ | ︙ | |||
2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 | * 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". */ createdNewObj = 0; createVar = 1; /* * Use the TCL_TRACE_READS flag to ensure that if we have an * array with no elements set yet, but with a read trace on it, * we will create the variable and get read traces triggered. */ | > > > > > | > > > > > > > > > > > > > > > > < < < < < < < < < < < < < | < < < < | 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 |
* 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".
*/
createdNewObj = 0;
createVar = 1;
/*
* Use the TCL_TRACE_READS flag to ensure that if we have an
* array with no elements set yet, but with a read trace on it,
* we will create the variable and get read traces triggered.
* 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_TRACE_READS | TCL_LEAVE_ERR_MSG));
varPtr->refCount--;
if (arrayPtr != NULL) {
arrayPtr->refCount--;
}
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.
*/
createVar = (TclIsVarUndefined(varPtr));
varValuePtr = Tcl_NewObj();
createdNewObj = 1;
} else if (Tcl_IsShared(varValuePtr)) {
varValuePtr = Tcl_DuplicateObj(varValuePtr);
createdNewObj = 1;
}
|
| ︙ | ︙ | |||
3021 3022 3023 3024 3025 3026 3027 | /* * 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. */ | | | | 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 |
/*
* 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) {
if (createdNewObj && !createVar) {
Tcl_DecrRefCount(varValuePtr); /* free unneeded obj */
}
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
3081 3082 3083 3084 3085 3086 3087 |
"anymore", "donesearch", "exists", "get", "names", "nextelement",
"set", "size", "startsearch", "statistics", "unset", (char *) NULL
};
Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
| | > | | | | | 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 |
"anymore", "donesearch", "exists", "get", "names", "nextelement",
"set", "size", "startsearch", "statistics", "unset", (char *) NULL
};
Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *resultPtr, *varNamePtr;
int notArray;
char *varName;
int index, result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
/*
* Locate the array variable
*/
varNamePtr = objv[2];
varName = TclGetString(varNamePtr);
varPtr = TclObjLookupVar(interp, varNamePtr, NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
/*
* Special array trace used to keep the env array in sync for
* array names, array get, etc.
*/
if (varPtr != NULL && varPtr->tracePtr != NULL
&& (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) {
if (TCL_ERROR == CallVarTraces(iPtr, arrayPtr, varPtr, varName, NULL,
(TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY|
TCL_TRACE_ARRAY), /* leaveErrMsg */ 1)) {
return TCL_ERROR;
}
}
/*
* Verify that it is indeed an array variable. This test comes after
* the traces - the variable may actually become an array as an effect
* of said traces.
*/
notArray = 0;
if ((varPtr == NULL) || !TclIsVarArray(varPtr)
|| TclIsVarUndefined(varPtr)) {
notArray = 1;
}
/*
* We have to wait to get the resultPtr until here because
* CallVarTraces can affect the result.
*/
resultPtr = Tcl_GetObjResult(interp);
switch (index) {
case ARRAY_ANYMORE: {
ArraySearch *searchPtr;
|
| ︙ | ︙ | |||
3520 3521 3522 3523 3524 3525 3526 |
if (notArray) {
return TCL_OK;
}
if (objc == 3) {
/*
* When no pattern is given, just unset the whole array
*/
| | | | 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 |
if (notArray) {
return TCL_OK;
}
if (objc == 3) {
/*
* When no pattern is given, just unset the whole array
*/
if (TclObjUnsetVar2(interp, varNamePtr, NULL, 0)
!= TCL_OK) {
return TCL_ERROR;
}
} else {
pattern = Tcl_GetString(objv[3]);
for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
&search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
if (TclIsVarUndefined(varPtr2)) {
continue;
}
name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
if (Tcl_StringMatch(name, pattern) &&
(TclObjUnsetVar2(interp, varNamePtr, name, 0)
!= TCL_OK)) {
return TCL_ERROR;
}
}
}
break;
}
|
| ︙ | ︙ | |||
3579 3580 3581 3582 3583 3584 3585 |
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Obj *arrayNameObj; /* The array name. */
Tcl_Obj *arrayElemObj; /* The array elements list. If this is
* NULL, create an empty array. */
{
Var *varPtr, *arrayPtr;
Tcl_Obj **elemPtrs;
| | | | | < < | < | < | > | > > > > > > > > > | > > > > | | 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 |
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Obj *arrayNameObj; /* The array name. */
Tcl_Obj *arrayElemObj; /* The array elements list. If this is
* NULL, create an empty array. */
{
Var *varPtr, *arrayPtr;
Tcl_Obj **elemPtrs;
int result, elemLen, i, nameLen;
char *varName, *p;
varName = Tcl_GetStringFromObj(arrayNameObj, &nameLen);
p = varName + nameLen - 1;
if (*p == ')') {
while (--p >= varName) {
if (*p == '(') {
VarErrMsg(interp, varName, NULL, "set", needArray);
return TCL_ERROR;
}
}
}
varPtr = TclObjLookupVar(interp, arrayNameObj, NULL,
/*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "set", /*createPart1*/ 1,
/*createPart2*/ 0, &arrayPtr);
if (varPtr == NULL) {
return TCL_ERROR;
}
if (arrayElemObj != NULL) {
result = Tcl_ListObjGetElements(interp, arrayElemObj,
&elemLen, &elemPtrs);
if (result != TCL_OK) {
return result;
}
if (elemLen & 1) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"list must have an even number of elements", -1);
return TCL_ERROR;
}
if (elemLen > 0) {
/*
* We needn't worry about traces invalidating arrayPtr:
* should that be the case, TclPtrSetVar will return NULL
* so that we break out of the loop and return an error.
*/
for (i = 0; i < elemLen; i += 2) {
char *part2 = TclGetString(elemPtrs[i]);
Var *elemVarPtr = TclLookupArrayElement(interp, varName,
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;
}
}
|
| ︙ | ︙ | |||
3645 3646 3647 3648 3649 3650 3651 | /* * Either an array element, or a scalar: lose! */ VarErrMsg(interp, varName, (char *)NULL, "array set", needArray); return TCL_ERROR; } | < < < < < < < < < < < < < < < < | | | | | | | > > | < < < | < | > < | | < < < < < < < < < < < < < < | < < < | < < < | < < | | < < < < | | | > > > > | | | | < < < < < < < < < | | < < < < < | < < < < < < < < < < | < < | < > | < | < | < | < < < < < < < < | | > > > > | > > > > | < < < < < | < < < < | 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 |
/*
* Either an array element, or a scalar: lose!
*/
VarErrMsg(interp, varName, (char *)NULL, "array set", needArray);
return TCL_ERROR;
}
}
TclSetVarArray(varPtr);
TclClearVarUndefined(varPtr);
varPtr->value.tablePtr =
(Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(varPtr->value.tablePtr, TCL_STRING_KEYS);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ObjMakeUpvar --
*
* This procedure does all of the work of the "global" and "upvar"
* commands.
*
* Results:
* A standard Tcl completion code. If an error occurs then an
* error message is left in iPtr->result.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
* given by otherP1 and otherP2, so that references to myName are
* redirected to the other variable like a symbolic link.
*
*----------------------------------------------------------------------
*/
static int
ObjMakeUpvar(interp, framePtr, otherP1Ptr, otherP2, otherFlags, myName, myFlags, index)
Tcl_Interp *interp; /* Interpreter containing variables. Used
* for error messages, too. */
CallFrame *framePtr; /* Call frame containing "other" variable.
* 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. */
CONST 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;
CONST char *errMsg;
/*
* Find "other" in "framePtr". If not looking up other in just the
* current namespace, temporarily replace the current var frame
* pointer in the interpreter in order to use TclObjLookupVar.
*/
varFramePtr = iPtr->varFramePtr;
if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
iPtr->varFramePtr = framePtr;
}
otherPtr = TclObjLookupVar(interp, otherP1Ptr, otherP2,
(otherFlags | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (!(otherFlags & TCL_NAMESPACE_ONLY)) {
iPtr->varFramePtr = varFramePtr;
}
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
* leaving the namespace var's reference invalid.
*/
if (((otherP2 ? arrayPtr->nsPtr : otherPtr->nsPtr) == NULL)
&& ((myFlags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY))
|| (varFramePtr == NULL)
|| !varFramePtr->isProcCallFrame
|| (strstr(myName, "::") != NULL))) {
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.
*/
varPtr = TclLookupSimpleVar(interp, myName, myFlags, /*create*/ 1,
&errMsg, &index);
if (varPtr == NULL) {
VarErrMsg(interp, myName, NULL, "create", errMsg);
return TCL_ERROR;
}
}
if (varPtr == otherPtr) {
Tcl_SetResult((Tcl_Interp *) iPtr,
"can't upvar from variable to itself", TCL_STATIC);
return TCL_ERROR;
}
if (varPtr->tracePtr != NULL) {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
"\" has traces: can't use for upvar", (char *) NULL);
return TCL_ERROR;
} else if (!TclIsVarUndefined(varPtr)) {
/*
* The variable already existed. Make sure this variable "varPtr"
* isn't the same as "otherPtr" (avoid circular links). Also, if
* it's not an upvar then it's an error. If it is an upvar, then
* just disconnect it from the thing it currently refers to.
*/
if (TclIsVarLink(varPtr)) {
Var *linkPtr = varPtr->value.linkPtr;
if (linkPtr == otherPtr) {
return TCL_OK;
}
linkPtr->refCount--;
if (TclIsVarUndefined(linkPtr)) {
CleanupVar(linkPtr, (Var *) NULL);
}
} else {
Tcl_AppendResult((Tcl_Interp *) iPtr, "variable \"", myName,
"\" already exists", (char *) NULL);
return TCL_ERROR;
}
}
TclSetVarLink(varPtr);
TclClearVarUndefined(varPtr);
varPtr->value.linkPtr = otherPtr;
otherPtr->refCount++;
return TCL_OK;
|
| ︙ | ︙ | |||
3897 3898 3899 3900 3901 3902 3903 |
int
Tcl_UpVar(interp, frameName, varName, localName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *frameName; /* Name of the frame containing the source
* variable, such as "1" or "#0". */
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 |
int
Tcl_UpVar(interp, frameName, varName, localName, flags)
Tcl_Interp *interp; /* Command interpreter in which varName is
* to be looked up. */
CONST char *frameName; /* Name of the frame containing the source
* variable, such as "1" or "#0". */
CONST char *varName; /* Name of a variable in interp to link to.
* May be either a scalar name or an
* element in an array. */
CONST char *localName; /* Name of link variable. */
int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of localName. */
{
return Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags);
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpVar2 --
*
|
| ︙ | ︙ | |||
3970 3971 3972 3973 3974 3975 3976 |
int
Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
Tcl_Interp *interp; /* Interpreter containing variables. Used
* for error messages too. */
CONST char *frameName; /* Name of the frame containing the source
* variable, such as "1" or "#0". */
| | > > > > | | > > > | 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 |
int
Tcl_UpVar2(interp, frameName, part1, part2, localName, flags)
Tcl_Interp *interp; /* Interpreter containing variables. Used
* for error messages too. */
CONST char *frameName; /* Name of the frame containing the source
* variable, such as "1" or "#0". */
CONST char *part1;
CONST char *part2; /* Two parts of source variable name to
* link to. */
CONST char *localName; /* Name of link variable. */
int flags; /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of localName. */
{
int result;
CallFrame *framePtr;
Tcl_Obj *part1Ptr;
part1Ptr = Tcl_NewStringObj(part1, -1);
Tcl_IncrRefCount(part1Ptr);
result = TclGetFrame(interp, frameName, &framePtr);
if (result == -1) {
return TCL_ERROR;
}
result = ObjMakeUpvar(interp, framePtr, part1Ptr, part2, 0,
localName, flags, -1);
TclDecrRefCount(part1Ptr);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVariableFullName --
*
|
| ︙ | ︙ | |||
4114 4115 4116 4117 4118 4119 4120 |
tail++;
}
/*
* Link to the variable "varName" in the global :: namespace.
*/
| | | | | 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 |
tail++;
}
/*
* Link to the variable "varName" in the global :: namespace.
*/
result = ObjMakeUpvar(interp, (CallFrame *) NULL,
objPtr, NULL, /*otherFlags*/ TCL_GLOBAL_ONLY,
/*myName*/ tail, /*myFlags*/ 0, -1);
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 |
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
char *varName, *tail, *cp;
Var *varPtr, *arrayPtr;
Tcl_Obj *varValuePtr;
int i, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
return TCL_ERROR;
}
for (i = 1; i < objc; i = i+2) {
/*
* Look up each variable in the current namespace context, creating
* it if necessary.
*/
| > > | | | 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 |
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
char *varName, *tail, *cp;
Var *varPtr, *arrayPtr;
Tcl_Obj *varValuePtr;
int i, result;
Tcl_Obj *varNamePtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?name value...? name ?value?");
return TCL_ERROR;
}
for (i = 1; i < objc; i = i+2) {
/*
* Look up each variable in the current namespace context, creating
* it if necessary.
*/
varNamePtr = objv[i];
varName = TclGetString(varNamePtr);
varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "define",
/*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
if (arrayPtr != NULL) {
/*
* Variable cannot be an element in an array. If arrayPtr is
* non-null, it is, so throw up an error and return.
|
| ︙ | ︙ | |||
4221 4222 4223 4224 4225 4226 4227 |
* Otherwise, if the variable is new, leave it undefined.
* (If the variable already exists and no value was specified,
* leave its value unchanged; just create the local link if
* we're in a Tcl procedure).
*/
if (i+1 < objc) { /* a value was specified */
| | | | 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 |
* Otherwise, if the variable is new, leave it undefined.
* (If the variable already exists and no value was specified,
* leave its value unchanged; just create the local link if
* we're in a Tcl procedure).
*/
if (i+1 < objc) { /* a value was specified */
varValuePtr = TclPtrSetVar(interp, varPtr, arrayPtr, varName, NULL,
objv[i+1], (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG));
if (varValuePtr == NULL) {
return TCL_ERROR;
}
}
/*
* If we are executing inside a Tcl procedure, create a local
|
| ︙ | ︙ | |||
4256 4257 4258 4259 4260 4261 4262 | } /* * Create a local link "tail" to the variable "varName" in the * current namespace. */ | | | | | 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 |
}
/*
* Create a local link "tail" to the variable "varName" in the
* current namespace.
*/
result = ObjMakeUpvar(interp, (CallFrame *) NULL,
/*otherP1*/ varNamePtr, /*otherP2*/ NULL,
/*otherFlags*/ TCL_NAMESPACE_ONLY,
/*myName*/ tail, /*myFlags*/ 0, -1);
if (result != TCL_OK) {
return result;
}
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
4293 4294 4295 4296 4297 4298 4299 |
int
Tcl_UpvarObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
| < | < | 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 |
int
Tcl_UpvarObjCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
CallFrame *framePtr;
char *frameSpec, *localName;
int result;
if (objc < 3) {
upvarSyntax:
Tcl_WrongNumArgs(interp, 1, objv,
"?level? otherVar localVar ?otherVar localVar ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
4329 4330 4331 4332 4333 4334 4335 |
/*
* Iterate over each (other variable, local variable) pair.
* Divide the other variable name into two parts, then call
* MakeUpvar to do all the work of linking it to the local variable.
*/
for ( ; objc > 0; objc -= 2, objv += 2) {
| | < < < < | < < < < < < < < < < < < < < < < < < < < | < | 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 |
/*
* Iterate over each (other variable, local variable) pair.
* Divide the other variable name into two parts, then call
* MakeUpvar to do all the work of linking it to the local variable.
*/
for ( ; objc > 0; objc -= 2, objv += 2) {
localName = TclGetString(objv[1]);
result = ObjMakeUpvar(interp, framePtr, /* othervarName */ objv[0],
NULL, 0, /* myVarName */ localName, /*flags*/ 0, -1);
if (result != TCL_OK) {
return TCL_ERROR;
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
4399 4400 4401 4402 4403 4404 4405 |
Tcl_DecrRefCount((Tcl_Obj *) result);
}
}
/*
*----------------------------------------------------------------------
*
| | | 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 |
Tcl_DecrRefCount((Tcl_Obj *) result);
}
}
/*
*----------------------------------------------------------------------
*
* CallVarTraces --
*
* This procedure is invoked to find and invoke relevant
* trace procedures associated with a particular operation on
* a variable. This procedure invokes traces both on the
* variable and on its containing array (where relevant).
*
* Results:
|
| ︙ | ︙ | |||
4421 4422 4423 4424 4425 4426 4427 | * Almost anything can happen, depending on trace; this procedure * itself doesn't have any side effects. * *---------------------------------------------------------------------- */ int | | | | | > | 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 |
* Almost anything can happen, depending on trace; this procedure
* itself doesn't have any side effects.
*
*----------------------------------------------------------------------
*/
int
CallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags, leaveErrMsg)
Interp *iPtr; /* Interpreter containing variable. */
register Var *arrayPtr; /* Pointer to array variable that contains
* the variable, or NULL if the variable
* isn't an element of an array. */
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,
* TCL_NAMESPACE_ONLY, and
* TCL_INTERP_DESTROYED. */
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;
/*
* If there are already similar trace procedures active for the
|
| ︙ | ︙ | |||
4481 4482 4483 4484 4485 4486 4487 4488 4489 |
openParen = p;
do {
p++;
} while (*p != '\0');
p--;
if (*p == ')') {
int offset = (openParen - part1);
Tcl_DStringInit(&nameCopy);
Tcl_DStringAppend(&nameCopy, part1, (p-part1));
| > < | | > > | | | 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 |
openParen = p;
do {
p++;
} while (*p != '\0');
p--;
if (*p == ')') {
int offset = (openParen - part1);
char *newPart1;
Tcl_DStringInit(&nameCopy);
Tcl_DStringAppend(&nameCopy, part1, (p-part1));
newPart1 = Tcl_DStringValue(&nameCopy);
newPart1[offset] = 0;
part1 = newPart1;
part2 = newPart1 + offset + 1;
copiedName = 1;
}
break;
}
}
}
/*
* Invoke traces on the array containing the variable, if relevant.
*/
result = NULL;
active.nextPtr = iPtr->activeVarTracePtr;
iPtr->activeVarTracePtr = &active;
Tcl_Preserve((ClientData) iPtr);
if (arrayPtr != NULL && !(arrayPtr->flags & VAR_TRACE_ACTIVE)) {
active.varPtr = arrayPtr;
for (tracePtr = arrayPtr->tracePtr; tracePtr != NULL;
tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
|
| ︙ | ︙ | |||
4568 4569 4570 4571 4572 4573 4574 |
* Restore the variable's flags, remove the record of our active
* traces, and then return.
*/
done:
if (code == TCL_ERROR) {
if (leaveErrMsg) {
| | | 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 |
* 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;
}
case TCL_TRACE_WRITES: {
type = "set";
|
| ︙ | ︙ | |||
4601 4602 4603 4604 4605 4606 4607 |
arrayPtr->refCount--;
}
if (copiedName) {
Tcl_DStringFree(&nameCopy);
}
varPtr->flags &= ~VAR_TRACE_ACTIVE;
varPtr->refCount--;
| | | 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 |
arrayPtr->refCount--;
}
if (copiedName) {
Tcl_DStringFree(&nameCopy);
}
varPtr->flags &= ~VAR_TRACE_ACTIVE;
varPtr->refCount--;
iPtr->activeVarTracePtr = active.nextPtr;
Tcl_Release((ClientData) iPtr);
return code;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4733 4734 4735 4736 4737 4738 4739 |
*
*----------------------------------------------------------------------
*/
static ArraySearch *
ParseSearchId(interp, varPtr, varName, handleObj)
Tcl_Interp *interp; /* Interpreter containing variable. */
| | | | 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 |
*
*----------------------------------------------------------------------
*/
static ArraySearch *
ParseSearchId(interp, varPtr, varName, handleObj)
Tcl_Interp *interp; /* Interpreter containing variable. */
CONST Var *varPtr; /* Array variable search is for. */
CONST char *varName; /* Name of array variable that search is
* supposed to be for. */
Tcl_Obj *handleObj; /* Object containing id of search. Must have
* form "search-num-var" where "num" is a
* decimal number and "var" is a variable
* name. */
{
register char *string;
|
| ︙ | ︙ | |||
4901 4902 4903 4904 4905 4906 4907 | } /* * Invoke traces on the variable that is being deleted, then * free up the variable's space (no need to free the hash entry * here, unless we're dealing with a global variable: the * hash entries will be deleted automatically when the whole | | | | | 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 |
}
/*
* Invoke traces on the variable that is being deleted, then
* free up the variable's space (no need to free the hash entry
* here, unless we're dealing with a global variable: the
* hash entries will be deleted automatically when the whole
* table is deleted). Note that we give CallVarTraces the variable's
* fully-qualified name so that any called trace procedures can
* refer to these variables being deleted.
*/
if (varPtr->tracePtr != NULL) {
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr); /* until done with traces */
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr);
CallVarTraces(iPtr, (Var *) NULL, varPtr, Tcl_GetString(objPtr),
NULL, flags, /* leaveErrMsg */ 0);
Tcl_DecrRefCount(objPtr); /* free no longer needed obj */
while (varPtr->tracePtr != NULL) {
VarTrace *tracePtr = varPtr->tracePtr;
varPtr->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;
}
}
}
|
| ︙ | ︙ | |||
5036 5037 5038 5039 5040 5041 5042 |
/*
* Invoke traces on the variable that is being deleted. Then delete
* the variable's trace records.
*/
if (varPtr->tracePtr != NULL) {
| | | | 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 |
/*
* Invoke traces on the variable that is being deleted. Then delete
* the variable's trace records.
*/
if (varPtr->tracePtr != NULL) {
CallVarTraces(iPtr, (Var *) NULL, varPtr, varPtr->name, NULL,
flags, /* leaveErrMsg */ 0);
while (varPtr->tracePtr != NULL) {
VarTrace *tracePtr = varPtr->tracePtr;
varPtr->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;
}
}
}
|
| ︙ | ︙ | |||
5097 5098 5099 5100 5101 5102 5103 |
*
*----------------------------------------------------------------------
*/
static void
DeleteArray(iPtr, arrayName, varPtr, flags)
Interp *iPtr; /* Interpreter containing array. */
| | | | 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 4752 4753 |
*
*----------------------------------------------------------------------
*/
static void
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_INTERP_DESTROYED,
* TCL_NAMESPACE_ONLY, or
* TCL_GLOBAL_ONLY. */
{
Tcl_HashSearch search;
register Tcl_HashEntry *hPtr;
|
| ︙ | ︙ | |||
5124 5125 5126 5127 5128 5129 5130 |
objPtr = elPtr->value.objPtr;
TclDecrRefCount(objPtr);
elPtr->value.objPtr = NULL;
}
elPtr->hPtr = NULL;
if (elPtr->tracePtr != NULL) {
elPtr->flags &= ~VAR_TRACE_ACTIVE;
| | | | 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 |
objPtr = elPtr->value.objPtr;
TclDecrRefCount(objPtr);
elPtr->value.objPtr = NULL;
}
elPtr->hPtr = NULL;
if (elPtr->tracePtr != NULL) {
elPtr->flags &= ~VAR_TRACE_ACTIVE;
CallVarTraces(iPtr, (Var *) NULL, elPtr, arrayName,
Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), flags,
/* leaveErrMsg */ 0);
while (elPtr->tracePtr != NULL) {
VarTrace *tracePtr = elPtr->tracePtr;
elPtr->tracePtr = tracePtr->nextPtr;
Tcl_EventuallyFree((ClientData) tracePtr,TCL_DYNAMIC);
}
for (activePtr = iPtr->activeVarTracePtr; activePtr != NULL;
activePtr = activePtr->nextPtr) {
if (activePtr->varPtr == elPtr) {
activePtr->nextTracePtr = NULL;
}
}
}
TclSetVarUndefined(elPtr);
|
| ︙ | ︙ | |||
5220 5221 5222 5223 5224 5225 5226 |
*
*----------------------------------------------------------------------
*/
static void
VarErrMsg(interp, part1, part2, operation, reason)
Tcl_Interp *interp; /* Interpreter in which to record message. */
| | | | < | 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 |
*
*----------------------------------------------------------------------
*/
static void
VarErrMsg(interp, part1, part2, operation, reason)
Tcl_Interp *interp; /* Interpreter in which to record message. */
CONST char *part1;
CONST char *part2; /* Variable's two-part name. */
CONST char *operation; /* String describing operation that failed,
* e.g. "read", "set", or "unset". */
CONST char *reason; /* String describing why operation failed. */
{
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't ", operation, " \"", part1,
(char *) NULL);
if (part2 != NULL) {
Tcl_AppendResult(interp, "(", part2, ")", (char *) NULL);
}
Tcl_AppendResult(interp, "\": ", reason, (char *) NULL);
}
/*
*----------------------------------------------------------------------
*
* TclTraceVarExists --
*
* This is called from info exists. We need to trigger read
|
| ︙ | ︙ | |||
5257 5258 5259 5260 5261 5262 5263 |
*
*----------------------------------------------------------------------
*/
Var *
TclVarTraceExists(interp, varName)
Tcl_Interp *interp; /* The interpreter */
| | | 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 |
*
*----------------------------------------------------------------------
*/
Var *
TclVarTraceExists(interp, varName)
Tcl_Interp *interp; /* The interpreter */
CONST char *varName; /* The variable name */
{
Var *varPtr;
Var *arrayPtr;
/*
* The choice of "create" flag values is delicate here, and
* matches the semantics of GetVar. Things are still not perfect,
|
| ︙ | ︙ | |||
5281 5282 5283 5284 5285 5286 5287 |
if (varPtr == NULL) {
return NULL;
}
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
if (varPtr == NULL) {
return NULL;
}
if ((varPtr->tracePtr != NULL)
|| ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
CallVarTraces((Interp *)interp, arrayPtr, varPtr, varName, NULL,
TCL_TRACE_READS, /* leaveErrMsg */ 0);
}
/*
* If the variable doesn't exist anymore and no-one's using
* it, then free up the relevant structures and hash table entries.
*/
if (TclIsVarUndefined(varPtr)) {
CleanupVar(varPtr, arrayPtr);
return NULL;
}
return varPtr;
}
/*
*----------------------------------------------------------------------
*
* Internal functions for variable name object types --
*
*----------------------------------------------------------------------
*/
/*
* localVarName -
*
* INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = pointer to the corresponding Proc
* twoPtrValue.ptr2 = index into locals table
*/
static void
FreeLocalVarName(objPtr)
Tcl_Obj *objPtr;
{
register Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
}
static void
DupLocalVarName(srcPtr, dupPtr)
Tcl_Obj *srcPtr;
Tcl_Obj *dupPtr;
{
register Proc *procPtr = (Proc *) srcPtr->internalRep.twoPtrValue.ptr1;
dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) procPtr;
dupPtr->internalRep.twoPtrValue.ptr2 = srcPtr->internalRep.twoPtrValue.ptr2;
procPtr->refCount++;
dupPtr->typePtr = &tclLocalVarNameType;
}
static void
UpdateLocalVarName(objPtr)
Tcl_Obj *objPtr;
{
Proc *procPtr = (Proc *) objPtr->internalRep.twoPtrValue.ptr1;
unsigned int index = (unsigned int) objPtr->internalRep.twoPtrValue.ptr2;
CompiledLocal *localPtr = procPtr->firstLocalPtr;
unsigned int nameLen;
if (localPtr == NULL) {
goto emptyName;
}
while (index--) {
localPtr = localPtr->nextPtr;
if (localPtr == NULL) {
goto emptyName;
}
}
nameLen = (unsigned int) localPtr->nameLength;
objPtr->bytes = ckalloc(nameLen + 1);
memcpy(objPtr->bytes, localPtr->name, nameLen + 1);
objPtr->length = nameLen;
return;
emptyName:
objPtr->bytes = ckalloc(1);
*(objPtr->bytes) = '\0';
objPtr->length = 0;
}
/*
* nsVarName -
*
* INTERNALREP DEFINITION:
* twoPtrValue.ptr1: pointer to the namespace containing the
* reference.
* twoPtrValue.ptr2: pointer to the corresponding Var
*/
static void
FreeNsVarName(objPtr)
Tcl_Obj *objPtr;
{
register Var *varPtr = (Var *) objPtr->internalRep.twoPtrValue.ptr2;
varPtr->refCount--;
if (TclIsVarUndefined(varPtr) && (varPtr->refCount <= 0)) {
if (TclIsVarLink(varPtr)) {
Var *linkPtr = varPtr->value.linkPtr;
linkPtr->refCount--;
if (TclIsVarUndefined(linkPtr) && (linkPtr->refCount <= 0)) {
CleanupVar(linkPtr, (Var *) NULL);
}
}
CleanupVar(varPtr, NULL);
}
}
static void
DupNsVarName(srcPtr, dupPtr)
Tcl_Obj *srcPtr;
Tcl_Obj *dupPtr;
{
Namespace *nsPtr = (Namespace *) srcPtr->internalRep.twoPtrValue.ptr1;
register Var *varPtr = (Var *) srcPtr->internalRep.twoPtrValue.ptr2;
dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) nsPtr;
dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) varPtr;
varPtr->refCount++;
dupPtr->typePtr = &tclNsVarNameType;
}
/*
* parsedVarName -
*
* INTERNALREP DEFINITION:
* twoPtrValue.ptr1 = pointer to the array name Tcl_Obj
* (NULL if scalar)
* twoPtrValue.ptr2 = pointer to the element name string
* (owned by this Tcl_Obj), or NULL if
* it is a scalar variable
*/
static void
FreeParsedVarName(objPtr)
Tcl_Obj *objPtr;
{
register Tcl_Obj *arrayPtr =
(Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
register char *elem = (char *) objPtr->internalRep.twoPtrValue.ptr2;
if (arrayPtr != NULL) {
TclDecrRefCount(arrayPtr);
ckfree(elem);
}
}
static void
DupParsedVarName(srcPtr, dupPtr)
Tcl_Obj *srcPtr;
Tcl_Obj *dupPtr;
{
register Tcl_Obj *arrayPtr =
(Tcl_Obj *) srcPtr->internalRep.twoPtrValue.ptr1;
register char *elem = (char *) srcPtr->internalRep.twoPtrValue.ptr2;
char *elemCopy;
unsigned int elemLen;
if (arrayPtr != NULL) {
Tcl_IncrRefCount(arrayPtr);
elemLen = strlen(elem);
elemCopy = ckalloc(elemLen+1);
memcpy(elemCopy, elem, elemLen);
*(elemCopy + elemLen) = '\0';
elem = elemCopy;
}
dupPtr->internalRep.twoPtrValue.ptr1 = (VOID *) arrayPtr;
dupPtr->internalRep.twoPtrValue.ptr2 = (VOID *) elem;
dupPtr->typePtr = &tclParsedVarNameType;
}
static void
UpdateParsedVarName(objPtr)
Tcl_Obj *objPtr;
{
Tcl_Obj *arrayPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr1;
char *part2 = (char *) objPtr->internalRep.twoPtrValue.ptr2;
char *part1, *p;
int len1, len2, totalLen;
if (arrayPtr == NULL) {
/*
* This is a parsed scalar name: what is it
* doing here?
*/
panic("ERROR: scalar parsedVarName without a string rep.\n");
}
part1 = Tcl_GetStringFromObj(arrayPtr, &len1);
len2 = strlen(part2);
totalLen = len1 + len2 + 2;
p = ckalloc((unsigned int) totalLen + 1);
objPtr->bytes = p;
objPtr->length = totalLen;
memcpy(p, part1, (unsigned int) len1);
p += len1;
*p++ = '(';
memcpy(p, part2, (unsigned int) len2);
p += len2;
*p++ = ')';
*p = '\0';
}
|
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.8.8.1 2002/08/20 20:25:27 das 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. # |
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
global env errorInfo
set dirs {}
set errors {}
# The C application may have hardwired a path, which we honor
| > | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
global env errorInfo
set dirs {}
set errors {}
# The C application may have hardwired a path, which we honor
set variableSet [info exists the_library]
if {$variableSet && [string compare $the_library {}]} {
lappend dirs $the_library
} else {
# Do the canonical search
# 1. From an environment variable, if it exists
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
if {[interp issafe] || [file exists $file]} {
if {![catch {uplevel #0 [list source $file]} msg]} {
return
} else {
append errors "$file: $msg\n$errorInfo\n"
}
}
}
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
}
| > > > | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
if {[interp issafe] || [file exists $file]} {
if {![catch {uplevel #0 [list source $file]} msg]} {
return
} else {
append errors "$file: $msg\n$errorInfo\n"
}
}
}
if {!$variableSet} {
unset 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
}
|
| ︙ | ︙ |
Changes to library/http/http.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # 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. # | | > | 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 |
# 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.39.8.3 2002/08/20 20:25:27 das 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.2
# keep this in sync with pkgIndex.tcl
# and with the install directories in Makefiles
package provide http 2.4.2
namespace eval http {
variable http
array set http {
-accept */*
-proxyhost {}
|
| ︙ | ︙ |
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.49.8.2 2002/08/20 20:25:27 das 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. |
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | # tcl_library, which is the directory containing this init.tcl script. # tclInitScript.h searches around for the directory containing this # init.tcl and defines tcl_library to that location before sourcing it. # # The parent directory of tcl_library. Adding the parent # means that packages in peer directories will be found automatically. # | | | > > > | | | | | | | | | | | | | | | | | | | < < | | > | | | | | | | | | | > | > | | | | < < < < < < | | | | | | > > > | 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 |
# tcl_library, which is the directory containing this init.tcl script.
# tclInitScript.h searches around for the directory containing this
# init.tcl and defines tcl_library to that location before sourcing it.
#
# The parent directory of tcl_library. Adding the parent
# means that packages in peer directories will be found automatically.
#
# Also add the directory ../lib relative to the directory where the
# executable is located. This is meant to find binary packages for the
# same architecture as the current executable.
#
# tcl_pkgPath, which is set by the platform-specific initialization routines
# On UNIX it is compiled in
# On Windows, it is not used
# On Macintosh it is "Tool Command Language" in the Extensions folder
if {![info exists auto_path]} {
if {[info exist env(TCLLIBPATH)]} {
set auto_path $env(TCLLIBPATH)
} else {
set auto_path ""
}
}
namespace eval tcl {
variable Dir
if {[string compare [info library] {}]} {
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 \
[info nameofexecutable]]] lib]
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
if {[info exist ::tcl_pkgPath]} {
foreach Dir $::tcl_pkgPath {
if {[lsearch -exact $::auto_path $Dir] < 0} {
lappend ::auto_path $Dir
}
}
}
}
# Windows specific end of initialization
if {(![interp issafe]) && [string equal $tcl_platform(platform) "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 {[string compare $u $p]} {
switch -- $u {
COMSPEC -
PATH {
if {![info exists env($u)]} {
set env($u) $env($p)
}
trace variable env($p) w \
[namespace code [list EnvTraceProc $p]]
trace variable env($u) w \
[namespace code [list EnvTraceProc $p]]
}
}
}
}
if {![info exists env(COMSPEC)]} {
if {[string equal $tcl_platform(os) "Windows NT"]} {
set env(COMSPEC) cmd.exe
} else {
set env(COMSPEC) command.com
}
}
}
InitWinEnv
}
}
# Setup the unknown package handler
package unknown tclPkgUnknown
|
| ︙ | ︙ | |||
630 631 632 633 634 635 636 |
}
}
return ""
}
}
| < < | | 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 |
}
}
return ""
}
}
# ::tcl::CopyDirectory --
#
# This procedure is called by Tcl's core when attempts to call the
# filesystem's copydirectory function fail. The semantics of the call
# are that 'dest' does not yet exist, i.e. dest should become the exact
# image of src. If dest does exist, we throw an error.
#
# Note that making changes to this procedure can change the results
# of running Tcl's tests.
#
# 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 {[string equal $action "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\
|
| ︙ | ︙ |
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 |
# 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.11.8.2 2002/08/20 20:25:27 das 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
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
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
# parent namespace until the source is found. If additional args are
|
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
# Returns the translatd string. Propagates errors thrown by the
# format command.
proc msgcat::mc {src args} {
# Check for the src in each namespace starting from the local and
# ending in the global.
| | | | | | | | | | | | | | | | | | | 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 |
# Returns the translatd string. Propagates errors thrown by the
# format command.
proc msgcat::mc {src args} {
# Check for the src in each namespace starting from the local and
# ending in the global.
variable Msgs
variable Loclist
variable Locale
set ns [uplevel 1 [list ::namespace current]]
while {$ns != ""} {
foreach loc $Loclist {
if {[info exists Msgs($loc,$ns,$src)]} {
if {[llength $args] == 0} {
return $Msgs($loc,$ns,$src)
} else {
return [uplevel 1 \
[linsert $args 0 ::format $Msgs($loc,$ns,$src)]]
}
}
}
set ns [namespace parent $ns]
}
# we have not found the translation
return [uplevel 1 \
[linsert $args 0 [::namespace origin mcunknown] $Locale $src]]
}
# msgcat::mclocale --
#
# Query or set the current locale.
#
# Arguments:
# newLocale (Optional) The new locale string. Locale strings
# should be composed of one or more sublocale parts
# separated by underscores (e.g. en_US).
#
# Results:
# Returns the current locale.
proc msgcat::mclocale {args} {
variable Loclist
variable Locale
set len [llength $args]
if {$len > 1} {
error {wrong # args: should be "mclocale ?newLocale?"}
}
if {$len == 1} {
set Locale [string tolower [lindex $args 0]]
set Loclist {}
set word ""
foreach part [split $Locale _] {
set word [string trimleft "${word}_${part}" _]
set Loclist [linsert $Loclist 0 $word]
}
}
return $Locale
}
# msgcat::mcpreferences --
#
# Fetch the list of locales used to look up strings, ordered from
# most preferred to least preferred.
#
# Arguments:
# None.
#
# Results:
# Returns an ordered list of the locales preferred by the user.
proc msgcat::mcpreferences {} {
variable Loclist
return $Loclist
}
# msgcat::mcload --
#
# Attempt to load message catalogs for each locale in the
# preference list from the specified directory.
#
|
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
# dest (Optional) The translated string. If omitted,
# the source string is used.
#
# Results:
# Returns the new locale.
proc msgcat::mcset {locale src {dest ""}} {
| | | | | | 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 |
# dest (Optional) The translated string. If omitted,
# the source string is used.
#
# Results:
# Returns the new locale.
proc msgcat::mcset {locale src {dest ""}} {
variable Msgs
if {[string equal $dest ""]} {
set dest $src
}
set ns [uplevel 1 [list ::namespace current]]
set Msgs([string tolower $locale],$ns,$src) $dest
return $dest
}
# msgcat::mcmset --
#
# Set the translation for multiple strings in a specified locale.
#
# Arguments:
# locale The locale to use.
# pairs One or more src/dest pairs (must be even length)
#
# Results:
# Returns the number of pairs processed
proc msgcat::mcmset {locale pairs } {
variable Msgs
set length [llength $pairs]
if {$length % 2} {
error {bad translation list: should be "mcmset locale {src dest ...}"}
}
set locale [string tolower $locale]
set ns [uplevel 1 [list ::namespace current]]
foreach {src dest} $pairs {
set Msgs($locale,$ns,$src) $dest
}
return $length
}
# msgcat::mcunknown --
#
|
| ︙ | ︙ | |||
248 249 250 251 252 253 254 |
if {$len>$max} {
set max $len
}
}
return $max
}
| | | | | | < < < < | > > > > | | | | > > > | > > | > > > > > | < < | | < | | < > > > | < | < | > > > | < < < | | < > | | | | | < < > > | | | > | | > | > | > > > | > | < > > > | | < < > | 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 |
if {$len>$max} {
set max $len
}
}
return $max
}
# Convert the locale values stored in environment variables to a form
# suitable for passing to [mclocale]
proc msgcat::ConvertLocale {value} {
# Assume $value is of form: $language[_$territory][.$codeset][@modifier]
# Convert to form: $language[_$territory][_$modifier]
#
# Comment out expanded RE version -- bugs alleged
# regexp -expanded {
# ^ # 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
regexp {^([^_.@]*)(_([^.@]*))?([.]([^@]*))?(@(.*))?$} $value \
-> language _ territory _ codeset _ modifier
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)]} {
mclocale [ConvertLocale $::env($varName)]
return
}
}
#
# On Windows, try to set locale depending on registry settings,
# or fall back on locale of "C". Other platforms will return
# when they fail to load the registry package.
#
set key {HKEY_CURRENT_USER\Control Panel\International}
if {[catch {package require registry}] \
|| [catch {registry get $key "locale"} locale]} {
mclocale C
return
}
#
# Keep trying to match against smaller and smaller suffixes
# of the registry value, since the latter hexadigits appear
# to determine general language and earlier hexadigits determine
# more precise information, such as territory. For example,
# 0409 - English - United States
# 0809 - English - United Kingdom
# Add more translations to the WinRegToISO639 array above.
#
variable WinRegToISO639
set locale [string tolower $locale]
while {[string length $locale]} {
if {![catch {mclocale [ConvertLocale $WinRegToISO639($locale)]}]} {
return
}
set locale [string range $locale 1 end]
}
#
# No translation known. Fall back on "C" locale
#
mclocale C
}
msgcat::Init
|
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 [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 |
# 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.6.8.1 2002/08/20 20:25:27 das Exp $
package require Tcl 8
# When this version number changes, update the pkgIndex.tcl file
# and the install directory in the Makefiles.
package provide opt 0.4.3
namespace eval ::tcl {
# Exported APIs
namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \
OptProc OptProcArgGiven OptParse \
|
| ︙ | ︙ |
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 [list source [file join $dir tcltest.tcl]]
|
Changes to library/tcltest/tcltest.tcl.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 | # This design was based on the Tcl testing approach designed and # initially implemented by Mary Ann May-Pumphrey of Sun # Microsystems. # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # | > | > | | > > > > > > > > | > | > | > > > > | > | > > | > > > > | | > | > > > > | | > > > | > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < > > > > > > | > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | | | 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 |
# This design was based on the Tcl testing approach designed and
# initially implemented by Mary Ann May-Pumphrey of Sun
# Microsystems.
#
# 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.33.8.2 2002/08/20 20:25:27 das 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.
variable Version 2.2
# 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]
##### Export the public tcltest procs; several categories
#
# Export the main functional commands that do useful things
namespace export cleanupTests loadTestedCommands makeDirectory \
makeFile removeDirectory removeFile runAllTests test
# Export configuration commands that control the functional commands
namespace export configure customMatch errorChannel interpreter \
outputChannel testConstraint
# Export commands that are duplication (candidates for deprecation)
namespace export bytestring ;# dups [encoding convertfrom identity]
namespace export debug ;# [configure -debug]
namespace export errorFile ;# [configure -errfile]
namespace export limitConstraints ;# [configure -limitconstraints]
namespace export loadFile ;# [configure -loadfile]
namespace export loadScript ;# [configure -load]
namespace export match ;# [configure -match]
namespace export matchFiles ;# [configure -file]
namespace export matchDirectories ;# [configure -relateddir]
namespace export normalizeMsg ;# application of [customMatch]
namespace export normalizePath ;# [file normalize] (8.4)
namespace export outputFile ;# [configure -outfile]
namespace export preserveCore ;# [configure -preservecore]
namespace export singleProcess ;# [configure -singleproc]
namespace export skip ;# [configure -skip]
namespace export skipFiles ;# [configure -notfile]
namespace export skipDirectories ;# [configure -asidefromdir]
namespace export temporaryDirectory ;# [configure -tmpdir]
namespace export testsDirectory ;# [configure -testdir]
namespace export verbose ;# [configure -verbose]
namespace export viewFile ;# binary encoding [read]
namespace export workingDirectory ;# [cd] [pwd]
# Export deprecated commands for tcltest 1 compatibility
namespace export getMatchingFiles mainThread restoreState saveState \
threadReap
# tcltest::normalizePath --
#
# This procedure resolves any symlinks in the path thus creating
# a path without internal redirection. It assumes that the
# incoming path is absolute.
#
# Arguments
# pathVar - name of variable containing path to modify.
#
# Results
# The path is modified in place.
#
# Side Effects:
# None.
#
proc normalizePath {pathVar} {
upvar $pathVar path
set oldpwd [pwd]
catch {cd $path}
set path [pwd]
cd $oldpwd
return $path
}
##### Verification commands used to test values of variables and options
#
# Verification command that accepts everything
proc AcceptAll {value} {
return $value
}
# Verification command that accepts valid Tcl lists
proc AcceptList { list } {
return [lrange $list 0 end]
}
# Verification command that accepts a glob pattern
proc AcceptPattern { pattern } {
return [AcceptAll $pattern]
}
# Verification command that accepts integers
proc AcceptInteger { level } {
return [incr level 0]
}
# Verification command that accepts boolean values
proc AcceptBoolean { boolean } {
return [expr {$boolean && $boolean}]
}
# Verification command that accepts (syntactically) valid Tcl scripts
proc AcceptScript { script } {
if {![info complete $script]} {
return -code error "invalid Tcl script: $script"
}
return $script
}
# Verification command that accepts (converts to) absolute pathnames
proc AcceptAbsolutePath { path } {
return [file join [pwd] $path]
}
# Verification command that accepts existing readable directories
proc AcceptReadable { path } {
if {![file readable $path]} {
return -code error "\"$path\" is not readable"
}
return $path
}
proc AcceptDirectory { directory } {
set directory [AcceptAbsolutePath $directory]
if {![file exists $directory]} {
return -code error "\"$directory\" does not exist"
}
if {![file isdir $directory]} {
return -code error "\"$directory\" is not a directory"
}
return [AcceptReadable $directory]
}
##### Initialize internal arrays of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
#
proc ArrayDefault {varName value} {
variable $varName
if {[array exists $varName]} {
return
}
if {[info exists $varName]} {
# Pre-initialized value is a scalar: destroy it!
unset $varName
}
array set $varName $value
}
# save the original environment so that it can be restored later
ArrayDefault originalEnv [array get ::env]
# initialize numTests array to keep track fo the number of tests
# that pass, fail, and are skipped.
ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
# numTests will store test files as indices and the list of files
# (that should not have been) left behind by the test files.
ArrayDefault createdNewFiles {}
# initialize skippedBecause array to keep track of constraints that
# kept tests from running; a constraint name of "userSpecifiedSkip"
# means that the test appeared on the list of tests that matched the
# -skip value given to the flag; "userSpecifiedNonMatch" means that
# the test didn't match the argument given to the -match flag; both
# of these constraints are counted only if tcltest::debug is set to
# true.
ArrayDefault skippedBecause {}
# initialize the testConstraints array to keep track of valid
# predefined constraints (see the explanation for the
# InitConstraints proc for more details).
ArrayDefault testConstraints {}
##### Initialize internal variables of tcltest, but only if the caller
# has not already pre-initialized them. This is done to support
# compatibility with older tests that directly access internals
# rather than go through command interfaces.
#
proc Default {varName value {verify AcceptAll}} {
variable $varName
if {![info exists $varName]} {
variable $varName [$verify $value]
} else {
variable $varName [$verify [set $varName]]
}
}
# Save any arguments that we might want to pass through to other
# programs. This is used by the -args flag.
# FINDUSER
Default parameters {}
# Count the number of files tested (0 if runAllTests wasn't called).
# runAllTests will set testSingleFile to false, so stats will
# not be printed until runAllTests calls the cleanupTests proc.
# The currentFailure var stores the boolean value of whether the
# current test file has had any failures. The failFiles list
# stores the names of test files that had failures.
Default numTestFiles 0 AcceptInteger
Default testSingleFile true AcceptBoolean
Default currentFailure false AcceptBoolean
Default failFiles {} AcceptList
# Tests should remove all files they create. The test suite will
# check the current working dir for files created by the tests.
# filesMade keeps track of such files created using the makeFile and
# makeDirectory procedures. filesExisted stores the names of
# pre-existing files.
Default filesMade {} AcceptList
Default filesExisted {} AcceptList
variable FilesExistedFilled 0
proc FillFilesExisted {} {
variable FilesExistedFilled
if {$FilesExistedFilled} {return}
variable filesExisted
# Save the names of files that already exist in the scratch directory.
foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
lappend filesExisted [file tail $file]
}
set FilesExistedFilled 1
}
# Kept only for compatibility
Default constraintsSpecified {} AcceptList
trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
[array names ::tcltest::testConstraints] ;# }
# tests that use threads need to know which is the main thread
Default mainThread 1
variable mainThread
if {[info commands thread::id] != {}} {
set mainThread [thread::id]
} elseif {[info commands testthread] != {}} {
set mainThread [testthread id]
}
# Set workingDirectory to [pwd]. The default output directory for
# Tcl tests is the working directory. Whenever this value changes
# change to that directory.
variable workingDirectory
trace variable workingDirectory w \
[namespace code {cd $workingDirectory ;#}]
Default workingDirectory [pwd] AcceptAbsolutePath
proc workingDirectory { {dir ""} } {
variable workingDirectory
if {[llength [info level 0]] == 1} {
return $workingDirectory
}
set workingDirectory [AcceptAbsolutePath $dir]
}
# Set the location of the execuatble
Default tcltest [info nameofexecutable]
trace variable tcltest w [namespace code {testConstraint stdio \
[eval [ConstraintInitializer stdio]] ;#}]
# save the platform information so it can be restored later
Default originalTclPlatform [array get ::tcl_platform]
# If a core file exists, save its modification time.
if {[file exists [file join [workingDirectory] core]]} {
Default coreModTime \
[file mtime [file join [workingDirectory] core]]
}
# stdout and stderr buffers for use when we want to store them
Default outData {}
Default errData {}
# keep track of test level for nested test commands
variable testLevel 0
# the variables and procs that existed when saveState was called are
# stored in a variable of the same name
Default saveState {}
# Internationalization support -- used in [SetIso8859_1_Locale] and
# [RestoreLocale]. Those commands are used in cmdIL.test.
if {![info exists [namespace current]::isoLocale]} {
variable isoLocale fr
switch -- $::tcl_platform(platform) {
"unix" {
# Try some 'known' values for some platforms:
switch -exact -- $::tcl_platform(os) {
"FreeBSD" {
set isoLocale fr_FR.ISO_8859-1
}
HP-UX {
set isoLocale fr_FR.iso88591
}
Linux -
|
| ︙ | ︙ | |||
239 240 241 242 243 244 245 |
}
"windows" {
set isoLocale French
}
}
}
| > > > > | > > > > > | > > | > > > > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | > > > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
"windows" {
set isoLocale French
}
}
}
# output goes to stdout by default
Default outputChannel stdout
proc outputChannel { {filename ""} } {
variable outputChannel
# Trigger auto-configuration of -outfile option, if needed.
# This is tricky because we have to trigger a trace on $debug
# so that traces attached to $outputFile are not disabled.
# We need them enabled to reflect changes back to outputChannel
set dummy [debug]
if {[llength [info level 0]] == 1} {
return $outputChannel
}
switch -exact -- $filename {
stderr -
stdout {
set outputChannel $filename
}
default {
set outputChannel [open $filename a]
}
}
return $outputChannel
}
# errors go to stderr by default
Default errorChannel stderr
proc errorChannel { {filename ""} } {
variable errorChannel
# Trigger auto-configuration of -errfile option, if needed.
# This is tricky because we have to trigger a trace on $debug
# so that traces attached to $outputFile are not disabled.
# We need them enabled to reflect changes back to outputChannel
set dummy [debug]
if {[llength [info level 0]] == 1} {
return $errorChannel
}
switch -exact -- $filename {
stderr -
stdout {
set errorChannel $filename
}
default {
set errorChannel [open $filename a]
}
}
return $errorChannel
}
##### Set up the configurable options
#
# The configurable options of the package
variable Option; array set Option {}
# Usage strings for those options
variable Usage; array set Usage {}
# Verification commands for those options
variable Verify; array set Verify {}
# Initialize the default values of the configurable options that are
# historically associated with an exported variable. If that variable
# is already set, support compatibility by accepting its pre-set value.
# Use [trace] to establish ongoing connection between the deprecated
# exported variable and the modern option kept as a true internal var.
# Also set up usage string and value testing for the option.
proc Option {option value usage {verify AcceptAll} {varName {}}} {
variable Option
variable Verify
variable Usage
variable OptionControlledVariables
set Usage($option) $usage
set Verify($option) $verify
if {[catch {$verify $value} msg]} {
return -code error $msg
} else {
set Option($option) $msg
}
if {[string length $varName]} {
variable $varName
if {[info exists $varName]} {
if {[catch {$verify [set $varName]} msg]} {
return -code error $msg
} else {
set Option($option) $msg
}
unset $varName
}
namespace eval [namespace current] \
[list upvar 0 Option($option) $varName]
# Workaround for Bug 572889. Grrrr....
# Track all the variables tied to options
lappend OptionControlledVariables $varName
# Later, set auto-configure read traces on all
# of them, since a single trace on Option does not work.
proc $varName {{value {}}} [subst -nocommands {
if {[llength [info level 0]] == 2} {
Configure $option [set value]
}
return [Configure $option]
}]
}
}
proc MatchingOption {option} {
variable Option
set match [array names Option $option*]
switch -- [llength $match] {
0 {
set sorted [lsort [array names Option]]
set values [join [lrange $sorted 0 end-1] ", "]
append values ", or [lindex $sorted end]"
return -code error "unknown option $option: should be\
one of $values"
}
1 {
return [lindex $match 0]
}
default {
# Exact match trumps ambiguity
if {[lsearch -exact $match $option] >= 0} {
return $option
}
set values [join [lrange $match 0 end-1] ", "]
append values ", or [lindex $match end]"
return -code error "ambiguous option $option:\
could match $values"
}
}
}
proc EstablishAutoConfigureTraces {} {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
}
}
proc RemoveAutoConfigureTraces {} {
variable OptionControlledVariables
foreach varName [concat $OptionControlledVariables Option] {
variable $varName
foreach pair [trace vinfo $varName] {
foreach {op cmd} $pair break
if {[string equal r $op]
&& [string match *ProcessCmdLineArgs* $cmd]} {
trace vdelete $varName $op $cmd
}
}
}
# One the traces are removed, this can become a no-op
proc RemoveAutoConfigureTraces {} {}
}
proc Configure args {
variable Option
variable Verify
set n [llength $args]
if {$n == 0} {
return [lsort [array names Option]]
}
if {$n == 1} {
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
return $Option($option)
}
while {[llength $args] > 1} {
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
if {[catch {$Verify($option) [lindex $args 1]} value]} {
return -code error "invalid $option\
value \"[lindex $args 1]\": $value"
}
set Option($option) $value
set args [lrange $args 2 end]
}
if {[llength $args]} {
if {[catch {MatchingOption [lindex $args 0]} option]} {
return -code error $option
}
return -code error "missing value for option $option"
}
}
proc configure args {
RemoveAutoConfigureTraces
set code [catch {eval Configure $args} msg]
return -code $code $msg
}
proc AcceptVerbose { level } {
set level [AcceptList $level]
if {[llength $level] == 1} {
if {![regexp {^(pass|body|skip|start|error)$} $level]} {
# translate single characters abbreviations to expanded list
set level [string map {p pass b body s skip t start e error} \
[split $level {}]]
}
}
set valid [list]
foreach v $level {
if {[regexp {^(pass|body|skip|start|error)$} $v]} {
lappend valid $v
}
}
return $valid
}
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 {
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
# Match and skip patterns default to the empty list, except for
# matchFiles, which defaults to all .test files in the
# testsDirectory and matchDirectories, which defaults to all
# directories.
Option -match * {
Run all tests within the specified files that match one of the
list of glob patterns given.
} AcceptList match
Option -skip {} {
Skip all tests within the specified tests (via -match) and files
that match one of the list of glob patterns given.
} AcceptList skip
Option -file *.test {
Run tests in all test files that match the glob pattern given.
} AcceptPattern matchFiles
# By default, skip files that appear to be SCCS lock files.
Option -notfile l.*.test {
Skip all test files that match the glob pattern given.
} AcceptPattern skipFiles
Option -relateddir * {
Run tests in directories that match the glob pattern given.
} AcceptPattern matchDirectories
Option -asidefromdir {} {
Skip tests in directories that match the glob pattern given.
} AcceptPattern skipDirectories
# By default, don't save core files
Option -preservecore 0 {
If 2, save any core files produced during testing in the directory
specified by -tmpdir. If 1, notify the user if core files are
created.
} AcceptInteger preserveCore
# debug output doesn't get printed by default; debug level 1 spits
# up only the tests that were skipped because they didn't match or
# were specifically skipped. A debug level of 2 would spit up the
# tcltest variables and flags provided; a debug level of 3 causes
# some additional output regarding operations of the test harness.
# The tcltest package currently implements only up to debug level 3.
Option -debug 0 {
Internal debug level
} AcceptInteger debug
proc SetSelectedConstraints args {
variable Option
foreach c $Option(-constraints) {
testConstraint $c 1
}
}
Option -constraints {} {
Do not skip the listed constraints listed in -constraints.
} AcceptList
trace variable Option(-constraints) w \
[namespace code {SetSelectedConstraints ;#}]
# Don't run only the "-constraint" specified tests by default
proc ClearUnselectedConstraints args {
variable Option
variable testConstraints
if {!$Option(-limitconstraints)} {return}
foreach c [array names testConstraints] {
if {[lsearch -exact $Option(-constraints) $c] == -1} {
testConstraint $c 0
}
}
}
Option -limitconstraints false {
whether to run only tests with the constraints
} AcceptBoolean limitConstraints
trace variable Option(-limitconstraints) w \
[namespace code {ClearUnselectedConstraints ;#}]
# A test application has to know how to load the tested commands
# into the interpreter.
Option -load {} {
Specifies the script to load the tested commands.
} AcceptScript loadScript
# Default is to run each test file in a separate process
Option -singleproc 0 {
whether to run all tests in one process
} AcceptBoolean singleProcess
proc AcceptTemporaryDirectory { directory } {
set directory [AcceptAbsolutePath $directory]
if {![file exists $directory]} {
file mkdir $directory
}
set directory [AcceptDirectory $directory]
if {![file writable $directory]} {
if {[string equal [workingDirectory] $directory]} {
# Special exception: accept the default value
# even if the directory is not writable
return $directory
}
return -code error "\"$directory\" is not writeable"
}
return $directory
}
# Directory where files should be created
Option -tmpdir [workingDirectory] {
Save temporary files in the specified directory.
} AcceptTemporaryDirectory temporaryDirectory
trace variable Option(-tmpdir) w \
[namespace code {normalizePath Option(-tmpdir) ;#}]
# Tests should not rely on the current working directory.
# Files that are part of the test suite should be accessed relative
# to [testsDirectory]
Option -testdir [workingDirectory] {
Search tests in the specified directory.
} AcceptDirectory testsDirectory
trace variable Option(-testdir) w \
[namespace code {normalizePath Option(-testdir) ;#}]
proc AcceptLoadFile { file } {
if {[string equal "" $file]} {return $file}
set file [file join [temporaryDirectory] $file]
return [AcceptReadable $file]
}
proc ReadLoadScript {args} {
variable Option
if {[string equal "" $Option(-loadfile)]} {return}
set tmp [open $Option(-loadfile) r]
loadScript [read $tmp]
close $tmp
}
Option -loadfile {} {
Read the script to load the tested commands from the specified file.
} AcceptLoadFile loadFile
trace variable Option(-loadfile) w [namespace code ReadLoadScript]
proc AcceptOutFile { file } {
if {[string equal stderr $file]} {return $file}
if {[string equal stdout $file]} {return $file}
return [file join [temporaryDirectory] $file]
}
# output goes to stdout by default
Option -outfile stdout {
Send output from test runs to the specified file.
} AcceptOutFile outputFile
trace variable Option(-outfile) w \
[namespace code {outputChannel $Option(-outfile) ;#}]
# errors go to stderr by default
Option -errfile stderr {
Send errors from test runs to the specified file.
} AcceptOutFile errorFile
trace variable Option(-errfile) w \
[namespace code {errorChannel $Option(-errfile) ;#}]
}
#####################################################################
# tcltest::Debug* --
#
# Internal helper procedures to write out debug information
|
| ︙ | ︙ | |||
353 354 355 356 357 358 359 |
uplevel 1 $script
}
return
}
#####################################################################
| < < < < < < < < < < < < < < < < < < < < < < < | < | < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
uplevel 1 $script
}
return
}
#####################################################################
proc tcltest::Warn {msg} {
puts [outputChannel] "WARNING: $msg"
}
# tcltest::mainThread
#
# Accessor command for tcltest variable mainThread.
#
proc tcltest::mainThread { {new ""} } {
variable mainThread
if {[llength [info level 0]] == 1} {
return $mainThread
}
set mainThread $new
}
# tcltest::testConstraint --
#
# sets a test constraint to a value; to do multiple constraints,
# call this proc multiple times. also returns the value of the
# named constraint if no value was supplied.
|
| ︙ | ︙ | |||
673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
# content of tcltest::testConstraints($constraint)
#
# Side effects:
# none
proc tcltest::testConstraint {constraint {value ""}} {
variable testConstraints
DebugPuts 3 "entering testConstraint $constraint $value"
if {[llength [info level 0]] == 2} {
return $testConstraints($constraint)
}
# Check for boolean values
if {[catch {expr {$value && $value}} msg]} {
return -code error $msg
}
set testConstraints($constraint) $value
}
| > > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
# content of tcltest::testConstraints($constraint)
#
# Side effects:
# none
proc tcltest::testConstraint {constraint {value ""}} {
variable testConstraints
variable Option
DebugPuts 3 "entering testConstraint $constraint $value"
if {[llength [info level 0]] == 2} {
return $testConstraints($constraint)
}
# Check for boolean values
if {[catch {expr {$value && $value}} msg]} {
return -code error $msg
}
if {[limitConstraints]
&& [lsearch -exact $Option(-constraints) $constraint] == -1} {
set value 0
}
set testConstraints($constraint) $value
}
# tcltest::interpreter --
#
# the interpreter name stored in tcltest::tcltest
#
# Arguments:
# executable name
#
|
| ︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 |
ConstraintInitializer unixOrWin \
{expr {[testConstraint unix] || [testConstraint win]}}
ConstraintInitializer macOrWin \
{expr {[testConstraint mac] || [testConstraint win]}}
ConstraintInitializer macOrUnix \
{expr {[testConstraint mac] || [testConstraint unix]}}
| | | | | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 |
ConstraintInitializer unixOrWin \
{expr {[testConstraint unix] || [testConstraint win]}}
ConstraintInitializer macOrWin \
{expr {[testConstraint mac] || [testConstraint win]}}
ConstraintInitializer macOrUnix \
{expr {[testConstraint mac] || [testConstraint unix]}}
ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
# The following Constraints switches are used to mark tests that
# should work, but have been temporarily disabled on certain
# platforms because they don't and we haven't gotten around to
# fixing the underlying problem.
ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
|
| ︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 |
}
set code
}
}
#####################################################################
| | < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > | > > > > > | < | < > | > > > | > > > > > | < > | > > > | < < < < | < > > > > | < < > > | < < | 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 |
}
set code
}
}
#####################################################################
# Usage and command line arguments processing.
# tcltest::PrintUsageInfo
#
# Prints out the usage information for package tcltest. This can
# be customized with the redefinition of [PrintUsageInfoHook].
#
# Arguments:
# none
#
# Results:
# none
#
# Side Effects:
# none
proc tcltest::PrintUsageInfo {} {
puts [Usage]
PrintUsageInfoHook
}
proc tcltest::Usage { {option ""} } {
variable Usage
variable Verify
if {[llength [info level 0]] == 1} {
set msg "Usage: [file tail [info nameofexecutable]] script "
append msg "?-help? ?flag value? ... \n"
append msg "Available flags (and valid input values) are:"
set max 0
set allOpts [concat -help [Configure]]
foreach opt $allOpts {
set foo [Usage $opt]
foreach [list x type($opt) usage($opt)] $foo break
set line($opt) " $opt $type($opt) "
set length($opt) [string length $line($opt)]
if {$length($opt) > $max} {set max $length($opt)}
}
set rest [expr {72 - $max}]
foreach opt $allOpts {
append msg \n$line($opt)
append msg [string repeat " " [expr {$max - $length($opt)}]]
set u [string trim $usage($opt)]
catch {append u " (default: \[[Configure $opt]])"}
regsub -all {\s*\n\s*} $u " " u
while {[string length $u] > $rest} {
set break [string wordstart $u $rest]
if {$break == 0} {
set break [string wordend $u 0]
}
append msg [string range $u 0 [expr {$break - 1}]]
set u [string trim [string range $u $break end]]
append msg \n[string repeat " " $max]
}
append msg $u
}
return $msg\n
} elseif {[string equal -help $option]} {
return [list -help "" "Display this usage information."]
} else {
set type [lindex [info args $Verify($option)] 0]
return [list $option $type $Usage($option)]
}
}
# tcltest::ProcessFlags --
#
# process command line arguments supplied in the flagArray - this
# is called by processCmdLineArgs. Modifies tcltest variables
# according to the content of the flagArray.
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 |
proc tcltest::ProcessFlags {flagArray} {
# Process -help first
if {[lsearch -exact $flagArray {-help}] != -1} {
PrintUsageInfo
exit 1
}
| | | < < < < < | | < | < < < | | < > | < < | < > | > | < | | < < > > | < < < | < < < | < < | | < < | | < | | < < < < < < < < < < < | < < | < | < < < | < | < < | | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > < < | > | < | < < < < < < < < < < < < | | | < < < | 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 |
proc tcltest::ProcessFlags {flagArray} {
# Process -help first
if {[lsearch -exact $flagArray {-help}] != -1} {
PrintUsageInfo
exit 1
}
if {[llength $flagArray] == 0} {
RemoveAutoConfigureTraces
} else {
set args $flagArray
while {[llength $args] && [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]
}
}
# Call the hook
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
# can be overridden.
#
# Perform configuration according to the command-line options.
#
# Arguments:
# none
#
# Results:
# Sets the above-named variables in the tcltest namespace.
#
# Side Effects:
# None.
#
proc tcltest::ProcessCmdLineArgs {} {
variable originalEnv
variable testConstraints
# The "argv" var doesn't exist in some cases, so use {}.
if {![info exists ::argv]} {
ProcessFlags {}
} else {
ProcessFlags $::argv
}
# 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]"
DebugPuts 2 "Original environment (tcltest::originalEnv):"
DebugPArray 2 originalEnv
DebugPuts 2 "Constraints:"
DebugPArray 2 testConstraints
}
#####################################################################
# Code to run the tests goes here.
# tcltest::TestPuts --
|
| ︙ | ︙ | |||
1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 |
}
}
if {[info exists channel]} {
if {[string equal $channel [[namespace parent]::outputChannel]]
|| [string equal $channel stdout]} {
append outData [lindex $args end]\n
} elseif {[string equal $channel [[namespace parent]::errorChannel]]
|| [string equal $channel stderr]} {
append errData [lindex $args end]\n
| > < | < > | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 |
}
}
if {[info exists channel]} {
if {[string equal $channel [[namespace parent]::outputChannel]]
|| [string equal $channel stdout]} {
append outData [lindex $args end]\n
return
} elseif {[string equal $channel [[namespace parent]::errorChannel]]
|| [string equal $channel stderr]} {
append errData [lindex $args end]\n
return
}
}
# If we haven't returned by now, we don't know how to handle the
# input. Let puts handle it.
return [eval Puts $args]
}
|
| ︙ | ︙ | |||
1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 |
# Side effects:
# Just about anything is possible depending on the test.
#
proc tcltest::test {name description args} {
global tcl_platform
variable testLevel
DebugPuts 3 "test $name $args"
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.
foreach item {constraints setup cleanup body result returnCodes
match} {
| > > | 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 |
# Side effects:
# Just about anything is possible depending on the test.
#
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.
foreach item {constraints setup cleanup body result returnCodes
match} {
|
| ︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 |
if {[llength $args] == 1} {
set list [SubstArguments [lindex $args 0]]
foreach {element value} $list {
set testAttributes($element) $value
}
foreach item {constraints match setup body cleanup \
result returnCodes output errorOutput} {
| | | | | | | 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 |
if {[llength $args] == 1} {
set list [SubstArguments [lindex $args 0]]
foreach {element value} $list {
set testAttributes($element) $value
}
foreach item {constraints match setup body cleanup \
result returnCodes output errorOutput} {
if {[info exists testAttributes(-$item)]} {
set testAttributes(-$item) [uplevel 1 \
::concat $testAttributes(-$item)]
}
}
} else {
array set testAttributes $args
}
set validFlags {-setup -cleanup -body -result -returnCodes \
-match -output -errorOutput -constraints}
foreach flag [array names testAttributes] {
if {[lsearch -exact $validFlags $flag] == -1} {
incr testLevel -1
set sorted [lsort $validFlags]
set options [join [lrange $sorted 0 end-1] ", "]
append options ", or [lindex $sorted end]"
return -code error "bad option \"$flag\": must be $options"
}
}
# store whatever the user gave us
foreach item [array names testAttributes] {
set [string trimleft $item "-"] $testAttributes($item)
}
# Check the values supplied for -match
variable CustomMatch
if {[lsearch [array names CustomMatch] $match] == -1} {
incr testLevel -1
set sorted [lsort [array names CustomMatch]]
set values [join [lrange $sorted 0 end-1] ", "]
append values ", or [lindex $sorted end]"
return -code error "bad -match value \"$match\":\
must be $values"
}
|
| ︙ | ︙ | |||
1974 1975 1976 1977 1978 1979 1980 |
set result [lindex $args end]
if {[llength $args] == 2} {
set body [lindex $args 0]
} elseif {[llength $args] == 3} {
set constraints [lindex $args 0]
set body [lindex $args 1]
} else {
| | > > | > | > > > > | > > | | | | > > > > > > > | | < < | < | < < | | | | | < < < | | | | | < | | | | < | | | | | | | | | | | | | | | | | | | | | | < | < < < | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | > > > | | | | | | | | < | | | | | | | | | | | > | | | | | > > | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | | < | < | | | | | | | | | | | | | | | < | | | | | | | | < | | | | | | < < < | < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < | < < | < < < < < < < | | < < | | | | | | | | | | | | | | < < < < < | | 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 |
set result [lindex $args end]
if {[llength $args] == 2} {
set body [lindex $args 0]
} elseif {[llength $args] == 3} {
set constraints [lindex $args 0]
set body [lindex $args 1]
} else {
incr testLevel -1
return -code error "wrong # args:\
should be \"test name desc ?options?\""
}
}
if {[Skipped $name $constraints]} {
incr testLevel -1
return
}
# Save information about the core file.
if {[preserveCore]} {
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]} {
if {[file exists [file join [workingDirectory] core]]} {
# There's only a test failure if there is a core file
# and (1) there previously wasn't one or (2) the new
# one is different from the old one.
if {[info exists coreModTime]} {
if {$coreModTime != [file mtime \
[file join [workingDirectory] core]]} {
set coreFailure 1
}
} else {
set coreFailure 1
}
if {([preserveCore] > 1) && ($coreFailure)} {
append coreMsg "\nMoving file to:\
[file join [temporaryDirectory] core-$name]"
catch {file rename -force \
[file join [workingDirectory] core] \
[file join [temporaryDirectory] core-$name]
} msg
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
if {[info exists output]} {
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]} {
if {[set errorCompare [catch {
CompareStrings $errData $errorOutput $match
} errorMatch]] == 0} {
set errorFailure [expr {!$errorMatch}]
} else {
set errorFailure 1
}
}
# check if the return code matched the expected return code
set codeFailure 0
if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
set codeFailure 1
}
# check if the answer matched the expected answer
# Only check if we ran the body of the test (no setup failure)
if {$setupFailure} {
set scriptFailure 0
} elseif {[set scriptCompare [catch {
CompareStrings $actualAnswer $result $match
} scriptMatch]] == 0} {
set scriptFailure [expr {!$scriptMatch}]
} else {
set scriptFailure 1
}
# if we didn't experience any failures, then we passed
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
|| $scriptFailure)} {
if {$testLevel == 1} {
incr numTests(Passed)
if {[IsVerbose pass]} {
puts [outputChannel] "++++ $name PASSED"
}
}
incr testLevel -1
return
}
# We know the test failed, tally it...
if {$testLevel == 1} {
incr numTests(Failed)
}
# ... then report according to the type of failure
variable currentFailure true
if {![IsVerbose body]} {
set body ""
}
puts [outputChannel] "\n==== $name\
[string trim $description] FAILED"
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\
($match matching):\n$result"
}
}
if {$codeFailure} {
switch -- $code {
0 { set msg "Test completed normally" }
1 { set msg "Test generated error" }
2 { set msg "Test generated return exception" }
3 { set msg "Test generated break exception" }
4 { set msg "Test generated continue exception" }
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $code"
puts [outputChannel] "---- Return code should have been\
one of: $returnCodes"
if {[IsVerbose error]} {
if {[info exists ::errorInfo]} {
puts [outputChannel] "---- errorInfo: $::errorInfo"
puts [outputChannel] "---- errorCode: $::errorCode"
}
}
}
if {$outputFailure} {
if {$outputCompare} {
puts [outputChannel] "---- Error testing output: $outputMatch"
} else {
puts [outputChannel] "---- Output was:\n$outData"
puts [outputChannel] "---- Output should have been\
($match matching):\n$output"
}
}
if {$errorFailure} {
if {$errorCompare} {
puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
} else {
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"
incr testLevel -1
return
}
# Skipped --
#
# Given a test name and it constraints, returns a boolean indicating
# whether the current configuration says the test should be skipped.
#
# Side Effects: Maintains tally of total tests seen and tests skipped.
#
proc tcltest::Skipped {name constraints} {
variable testLevel
variable numTests
variable testConstraints
if {$testLevel == 1} {
incr numTests(Total)
}
# skip the test if it's name matches an element of skip
foreach pattern [skip] {
if {[string match $pattern $name]} {
if {$testLevel == 1} {
incr numTests(Skipped)
DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
}
return 1
}
}
# skip the test if it's name doesn't match any element of match
set ok 0
foreach pattern [match] {
if {[string match $pattern $name]} {
set ok 1
break
}
}
if {!$ok} {
if {$testLevel == 1} {
incr numTests(Skipped)
DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
}
return 1
}
if {[string equal {} $constraints]} {
# If we're limited to the listed constraints and there aren't
# any listed, then we shouldn't run the test.
if {[limitConstraints]} {
AddToSkippedBecause userSpecifiedLimitConstraint
if {$testLevel == 1} {
incr numTests(Skipped)
}
return 1
}
} else {
# "constraints" argument exists;
# make sure that the constraints are satisfied.
set doTest 0
if {[string match {*[$\[]*} $constraints] != 0} {
|
| ︙ | ︙ | |||
2322 2323 2324 2325 2326 2327 2328 |
puts [outputChannel] "++++ $name SKIPPED: $constraints"
}
if {$testLevel == 1} {
incr numTests(Skipped)
AddToSkippedBecause $constraints
}
| | > | | < | | | | | < < < | | < > < < < < < | 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 |
puts [outputChannel] "++++ $name SKIPPED: $constraints"
}
if {$testLevel == 1} {
incr numTests(Skipped)
AddToSkippedBecause $constraints
}
return 1
}
}
return 0
}
# RunTest --
#
# This is where the body of a test is evaluated. The combination of
# [RunTest] and [Eval] allows the output and error output of the test
# body to be captured for comparison against the expected values.
proc tcltest::RunTest {name script} {
DebugPuts 3 "Running $name {$script}"
# If there is no "memory" command (because memory debugging isn't
# enabled), then don't attempt to use the command.
if {[llength [info commands memory]] == 1} {
memory tag $name
}
set code [catch {uplevel 1 $script} actualAnswer]
return [list $actualAnswer $code]
}
#####################################################################
|
| ︙ | ︙ | |||
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 |
variable failFiles
variable skippedBecause
variable currentFailure
variable originalEnv
variable originalTclPlatform
variable coreModTime
set testFileName [file tail [info script]]
# Call the cleanup hook
cleanupTestsHook
# Remove files and directories created by the makeFile and
# makeDirectory procedures. Record the names of files in
# workingDirectory that were not pre-existing, and associate them
# with the test file that created them.
if {!$calledFromAllFile} {
foreach file $filesMade {
if {[file exists $file]} {
catch {file delete -force $file}
}
}
set currentFiles {}
foreach file [glob -nocomplain \
-directory [temporaryDirectory] *] {
lappend currentFiles [file tail $file]
| > > | 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 |
variable failFiles
variable skippedBecause
variable currentFailure
variable originalEnv
variable originalTclPlatform
variable coreModTime
FillFilesExisted
set testFileName [file tail [info script]]
# Call the cleanup hook
cleanupTestsHook
# Remove files and directories created by the makeFile and
# makeDirectory procedures. Record the names of files in
# workingDirectory that were not pre-existing, and associate them
# with the test file that created them.
if {!$calledFromAllFile} {
foreach file $filesMade {
if {[file exists $file]} {
DebugDo 1 {Warn "cleanupTests deleting $file..."}
catch {file delete -force $file}
}
}
set currentFiles {}
foreach file [glob -nocomplain \
-directory [temporaryDirectory] *] {
lappend currentFiles [file tail $file]
|
| ︙ | ︙ | |||
2503 2504 2505 2506 2507 2508 2509 |
set filesMade {}
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
set numTests($index) 0
}
# exit only if running Tk in non-interactive mode
| | | > > | < | 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 |
set filesMade {}
foreach index [list "Total" "Passed" "Skipped" "Failed"] {
set numTests($index) 0
}
# exit only if running Tk in non-interactive mode
# This should be changed to determine if an event
# loop is running, which is the real issue.
# Actually, this doesn't belong here at all. A package
# really has no business [exit]-ing an application.
if {![catch {package present Tk}] && ![testConstraint interactive]} {
exit
}
} 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
|
| ︙ | ︙ | |||
2628 2629 2630 2631 2632 2633 2634 |
#
# Side Effects:
# None
# a lower case version is needed for compatibility with tcltest 1.0
proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args}
| | | > > | > > > > | > < < < < | | | > | | | | < | > > | < < | < | | | < < | | | | 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 |
#
# Side Effects:
# None
# a lower case version is needed for compatibility with tcltest 1.0
proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args}
proc tcltest::GetMatchingFiles { args } {
if {[llength $args]} {
set dirList $args
} else {
# Finding tests only in [testsDirectory] is normal operation.
# This procedure is written to accept multiple directory arguments
# only to satisfy version 1 compatibility.
set dirList [list [testsDirectory]]
}
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 -nocomplain -- $match]]
}
# List files in $directory that match patterns to skip.
set skipFileList [list]
foreach skip [skipFiles] {
set skipFileList [concat $skipFileList \
[glob -directory $directory -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
}
}
}
if {[llength $matchingFiles] == 0} {
PrintError "No test files remain after applying your match and\
skip patterns!"
}
return $matchingFiles
}
# tcltest::GetMatchingDirectories --
|
| ︙ | ︙ | |||
2688 2689 2690 2691 2692 2693 2694 |
# The constructed list is returned to the user. This is used in
# the primary all.tcl file.
#
# Side Effects:
# None.
proc tcltest::GetMatchingDirectories {rootdir} {
| | | | > | | | | < < < < | | | | | < > > | | < | < < | | > > > | | | < < | > > > | | < > | 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 |
# The constructed list is returned to the user. This is used in
# the primary all.tcl file.
#
# Side Effects:
# None.
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] {
foreach path [glob -directory $rootdir -nocomplain -- $pattern] {
if {[file isdirectory $path]} {
lappend skipDirs $path
}
}
}
# 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 -nocomplain -- $pattern] {
if {[file isdirectory $path]} {
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\
and skip patterns!"
}
return $matchDirs
}
# tcltest::runAllTests --
#
# prints output and sources test files according to the match and
# skip patterns provided. after sourcing test files, it goes on
# to source all.tcl files in matching test subdirectories.
#
# Arguments:
# shell being tested
#
# Results:
# None.
#
# Side effects:
# None.
proc tcltest::runAllTests { {shell ""} } {
variable testSingleFile
variable numTestFiles
variable numTests
variable failFiles
FillFilesExisted
if {[llength [info level 0]] == 1} {
set shell [interpreter]
}
set testSingleFile false
puts [outputChannel] "Tests running in interp: $shell"
|
| ︙ | ︙ | |||
2780 2781 2782 2783 2784 2785 2786 |
} else {
puts [outputChannel] \
"Test files run in separate interpreters"
}
if {[llength [skip]] > 0} {
puts [outputChannel] "Skipping tests that match: [skip]"
}
| < | < > > > > > > > > > | | 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 |
} else {
puts [outputChannel] \
"Test files run in separate interpreters"
}
if {[llength [skip]] > 0} {
puts [outputChannel] "Skipping tests that match: [skip]"
}
puts [outputChannel] "Running tests that match: [match]"
if {[llength [skipFiles]] > 0} {
puts [outputChannel] \
"Skipping test files that match: [skipFiles]"
}
if {[llength [matchFiles]] > 0} {
puts [outputChannel] \
"Only running test files that match: [matchFiles]"
}
set timeCmd {clock format [clock seconds]}
puts [outputChannel] "Tests began at [eval $timeCmd]"
# Run each of the specified tests
foreach file [lsort [GetMatchingFiles]] {
set tail [file tail $file]
puts [outputChannel] $tail
flush [outputChannel]
if {[singleProcess]} {
incr numTestFiles
uplevel 1 [list ::source $file]
} else {
# Pass along our configuration to the child processes.
# EXCEPT for the -outfile, because the parent process
# needs to read and process output of children.
set childargv [list]
foreach opt [Configure] {
if {[string equal $opt -outfile]} {continue}
lappend childargv $opt [Configure $opt]
}
set cmd [linsert $childargv 0 | $shell $file]
if {[catch {
incr numTestFiles
set pipeFd [open $cmd "r"]
while {[gets $pipeFd line] >= 0} {
if {[regexp [join {
{^([^:]+):\t}
{Total\t([0-9]+)\t}
|
| ︙ | ︙ | |||
2852 2853 2854 2855 2856 2857 2858 |
# cleanup
puts [outputChannel] "\nTests ended at [eval $timeCmd]"
cleanupTests 1
if {[info exists testFileFailures]} {
puts [outputChannel] "\nTest files exiting with errors: \n"
foreach file $testFileFailures {
| | | 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 |
# cleanup
puts [outputChannel] "\nTests ended at [eval $timeCmd]"
cleanupTests 1
if {[info exists testFileFailures]} {
puts [outputChannel] "\nTest files exiting with errors: \n"
foreach file $testFileFailures {
puts [outputChannel] " [file tail $file]\n"
}
}
# Checking for subdirectories in which to run tests
foreach directory [GetMatchingDirectories [testsDirectory]] {
set dir [file tail $directory]
puts [outputChannel] [string repeat ~ 44]
|
| ︙ | ︙ | |||
2998 2999 3000 3001 3002 3003 3004 |
# Results:
# absolute path to the file created
#
# Side effects:
# None.
proc tcltest::makeFile {contents name {directory ""}} {
| < > | < < | | 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 |
# Results:
# absolute path to the file created
#
# Side effects:
# None.
proc tcltest::makeFile {contents name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 3} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]:\
putting ``$contents'' into $fullName"
set fd [open $fullName w]
fconfigure $fd -translation lf
if {[string equal [string index $contents end] \n]} {
puts -nonewline $fd $contents
} else {
puts $fd $contents
}
close $fd
if {[lsearch -exact $filesMade $fullName] == -1} {
|
| ︙ | ︙ | |||
3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 |
# Results:
# return value from [file delete]
#
# Side effects:
# None.
proc tcltest::removeFile {name {directory ""}} {
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
return [file delete $fullName]
}
# tcltest::makeDirectory --
#
# Create a new dir with the name <name>.
#
| > > > > > > > > > > > > > > | 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 |
# Results:
# return value from [file delete]
#
# Side effects:
# None.
proc tcltest::removeFile {name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx == -1} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not created by makeFile"
}
}
if {![file isfile $fullName]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
return [file delete $fullName]
}
# tcltest::makeDirectory --
#
# Create a new dir with the name <name>.
#
|
| ︙ | ︙ | |||
3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 |
# absolute path to the directory created
#
# Side effects:
# None.
proc tcltest::makeDirectory {name {directory ""}} {
variable filesMade
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
file mkdir $fullName
if {[lsearch -exact $filesMade $fullName] == -1} {
| > | 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 |
# absolute path to the directory created
#
# Side effects:
# None.
proc tcltest::makeDirectory {name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
file mkdir $fullName
if {[lsearch -exact $filesMade $fullName] == -1} {
|
| ︙ | ︙ | |||
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 |
# Results:
# return value from [file delete]
#
# Side effects:
# None
proc tcltest::removeDirectory {name {directory ""}} {
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
return [file delete -force $fullName]
}
# tcltest::viewFile --
#
# reads the content of a file and returns it
#
# Arguments:
# name of the file to read
# directory in which file is located
#
# Results:
# content of the named file
#
# Side effects:
# None.
proc tcltest::viewFile {name {directory ""}} {
| > > > > > > > > > > > > > > > | < < | | | | < < < < | 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 |
# Results:
# return value from [file delete]
#
# Side effects:
# None
proc tcltest::removeDirectory {name {directory ""}} {
variable filesMade
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
set idx [lsearch -exact $filesMade $fullName]
set filesMade [lreplace $filesMade $idx $idx]
if {$idx == -1} {
DebugDo 1 {
Warn "removeDirectory removing \"$fullName\":\n not created\
by makeDirectory"
}
}
if {![file isdirectory $fullName]} {
DebugDo 1 {
Warn "removeDirectory removing \"$fullName\":\n not a directory"
}
}
return [file delete -force $fullName]
}
# tcltest::viewFile --
#
# reads the content of a file and returns it
#
# Arguments:
# name of the file to read
# directory in which file is located
#
# Results:
# content of the named file
#
# Side effects:
# None.
proc tcltest::viewFile {name {directory ""}} {
FillFilesExisted
if {[llength [info level 0]] == 2} {
set directory [temporaryDirectory]
}
set fullName [file join $directory $name]
set f [open $fullName]
set data [read -nonewline $f]
close $f
return $data
}
# tcltest::bytestring --
#
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
# This allows the tester to
|
| ︙ | ︙ | |||
3341 3342 3343 3344 3345 3346 3347 |
# straight away, without all this "hook" nonsense.
if {[string equal [namespace current] \
[namespace qualifiers [namespace which initConstraintsHook]]]} {
InitConstraints
} else {
proc initConstraintsHook {} {}
}
| < < < < < < < < | > > > > > > > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 |
# straight away, without all this "hook" nonsense.
if {[string equal [namespace current] \
[namespace qualifiers [namespace which initConstraintsHook]]]} {
InitConstraints
} else {
proc initConstraintsHook {} {}
}
# Define the standard match commands
customMatch exact [list string equal]
customMatch glob [list string match]
customMatch regexp [list regexp --]
# If the TCLTEST_OPTIONS environment variable exists, configure
# tcltest according to the option values it specifies. This has
# the effect of resetting tcltest's default configuration.
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
}
}
if {[info exists ::env(TCLTEST_OPTIONS)]} {
ConfigureFromEnvironment
}
proc LoadTimeCmdLineArgParsingRequired {} {
set required false
if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
# The command line asks for -help, so give it (and exit)
# right now. ([configure] does not process -help)
set required true
}
foreach hook { PrintUsageInfoHook processCmdLineArgsHook
processCmdLineArgsAddFlagsHook } {
if {[string equal [namespace current] [namespace qualifiers \
[namespace which $hook]]]} {
set required true
} else {
proc $hook args {}
}
}
return $required
}
# Only initialize configurable options from the command line arguments
# at package load time if necessary for backward compatibility. This
# lets the tcltest user call [configure] for themselves if they wish.
# Traces are established for auto-configuration from the command line
# if any configurable options are accessed before the user calls
# [configure].
if {[LoadTimeCmdLineArgParsingRequired]} {
ProcessCmdLineArgs
} else {
EstablishAutoConfigureTraces
}
package provide [namespace tail [namespace current]] $Version
}
|
Changes to license.terms.
1 | This software is copyrighted by the Regents of the University of | | | | > | 1 2 3 4 5 6 7 8 9 10 11 12 | This software is copyrighted by the Regents of the University of California, Sun Microsystems, Inc., Scriptics Corporation, ActiveState Corporation and other parties. The following terms apply to all files associated with the software unless explicitly disclaimed in individual files. The authors hereby grant 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 |
| ︙ | ︙ |
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.7.8.3 2002/08/20 20:25:27 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #include "tclMacInt.h" #include <Aliases.h> #include <Errors.h> |
| ︙ | ︙ | |||
737 738 739 740 741 742 743 | } /* *---------------------------------------------------------------------- * * TclpOpenFileChannel -- * | | | < < < < < < < | 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 |
}
/*
*----------------------------------------------------------------------
*
* TclpOpenFileChannel --
*
* Open a File based channel on MacOS systems.
*
* Results:
* The new channel or NULL. If NULL, the output argument
* errorCodePtr is set to a POSIX error.
*
* Side effects:
* May open the channel and may cause creation of a file on the
* file system.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpOpenFileChannel(
Tcl_Interp *interp, /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *pathPtr, /* Name of file to open. */
int mode, /* POSIX open mode. */
int permissions) /* If the open involves creating a
* file, with what modes to create
* it? */
{
Tcl_Channel chan;
CONST char *native;
int errorCode;
native = Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return NULL;
}
chan = OpenFileChannel(native, mode, permissions, &errorCode);
if (chan == NULL) {
|
| ︙ | ︙ |
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.12.8.3 2002/08/20 20:25:27 das 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. */ |
| ︙ | ︙ | |||
682 683 684 685 686 687 688 |
Tcl_UtfToExternalDString(NULL, path, -1, &ds);
/*
* Remove ending colons if they exist.
*/
| | > | > | 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 |
Tcl_UtfToExternalDString(NULL, path, -1, &ds);
/*
* Remove ending colons if they exist.
*/
while ((Tcl_DStringLength(&ds) != 0)
&& (Tcl_DStringValue(&ds)[Tcl_DStringLength(&ds) - 1] == ':')) {
Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 1);
}
end = strrchr(Tcl_DStringValue(&ds), ':');
if (end == NULL ) {
strcpy(fileName + 1, Tcl_DStringValue(&ds));
} else {
strcpy(fileName + 1, end + 1);
Tcl_DStringSetLength(&ds, end + 1 - Tcl_DStringValue(&ds));
}
fileName[0] = (char) strlen(fileName + 1);
/*
* Create the file spec for the directory of the file
* we want to look at.
*/
if (end != NULL) {
err = FSpLocationFromPath(Tcl_DStringLength(&ds),
Tcl_DStringValue(&ds), &fileSpec);
if (err != noErr) {
Tcl_DStringFree(&ds);
errno = EINVAL;
return NULL;
}
} else {
FSMakeFSSpecCompat(0, 0, NULL, &fileSpec);
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 |
Tcl_ExternalToUtfDString(NULL, *theString, pathSize, linkPtr);
DisposeHandle(theString);
return Tcl_DStringValue(linkPtr);
}
static int
| | > | 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
Tcl_ExternalToUtfDString(NULL, *theString, pathSize, linkPtr);
DisposeHandle(theString);
return Tcl_DStringValue(linkPtr);
}
static int
TclpObjStatAlias _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *bufPtr,
Boolean resolveLink));
/*
*----------------------------------------------------------------------
*
* TclpObjLstat --
*
|
| ︙ | ︙ | |||
1141 1142 1143 1144 1145 1146 1147 |
return TclpNativeToNormalized((ClientData) fileName);
}
#ifdef S_IFLNK
Tcl_Obj*
| | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
return TclpNativeToNormalized((ClientData) fileName);
}
#ifdef S_IFLNK
Tcl_Obj*
TclpObjLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr;
Tcl_Obj *toPtr;
int linkAction;
{
Tcl_Obj* link = NULL;
if (toPtr != NULL) {
if (TclpObjAccess(pathPtr, F_OK) != -1) {
/* src exists */
errno = EEXIST;
return NULL;
}
if (TclpObjAccess(toPtr, F_OK) == -1) {
/* target doesn't exist */
errno = ENOENT;
return NULL;
}
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
/* Needs to create a new link */
FSSpec spec;
FSSpec linkSpec;
OSErr err;
char *path;
AliasHandle alias;
err = FspLocationFromFsPath(toPtr, &spec);
if (err != noErr) {
errno = ENOENT;
return NULL;
}
path = Tcl_FSGetNativePath(pathPtr);
err = FSpLocationFromPath(strlen(path), path, &linkSpec);
if (err == noErr) {
err = dupFNErr; /* EEXIST. */
} else {
err = NewAlias(&spec, &linkSpec, &alias);
}
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
return NULL;
}
return toPtr;
} else {
errno = ENODEV;
return NULL;
}
} else {
Tcl_DString ds;
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
if (TclpReadlink(Tcl_GetString(transPtr), &ds) != NULL) {
|
| ︙ | ︙ |
Changes to mac/tclMacLoad.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclMacLoad.c -- * * This procedure provides a version of the TclLoadFile for use * on the Macintosh. This procedure will only work with systems * that use the Code Fragment Manager. * * 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 | /* * tclMacLoad.c -- * * This procedure provides a version of the TclLoadFile for use * on the Macintosh. This procedure will only work with systems * that use the Code Fragment Manager. * * 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: tclMacLoad.c,v 1.7.2.2 2002/08/20 20:25:27 das Exp $ */ #include <CodeFragments.h> #include <Errors.h> #include <Resources.h> #include <Strings.h> #include <FSpCompat.h> |
| ︙ | ︙ | |||
72 73 74 75 76 77 78 79 80 81 82 |
long codeLength;
long res1;
long res2;
short itemSize;
Str255 name; /* This is actually variable sized. */
};
typedef struct CfrgItem CfrgItem;
/*
*----------------------------------------------------------------------
*
| > > > > > > > > > > > > > > > > > > > | | | | | < < < < < < < | < < < < < < < < < > > > > > > > > > > > > > > > > | < < < > > | | > > | > > > > > > > > > | > > | > > | | | | | | | | | | | | | | | | | | > > > > | < | > | | < < | > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | | < < < < < < < < < < | | 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 |
long codeLength;
long res1;
long res2;
short itemSize;
Str255 name; /* This is actually variable sized. */
};
typedef struct CfrgItem CfrgItem;
/*
* On MacOS, old shared libraries which contain many code fragments
* cannot, it seems, be loaded in one go. We need to look provide
* the name of a code fragment while we load. Since with the
* separation of the 'load' and 'findsymbol' be do not necessarily
* know a symbol name at load time, we have to store some further
* information in a structure like this so we can ensure we load
* properly in 'findsymbol' if the first attempts didn't work.
*/
typedef struct TclMacLoadInfo {
int loaded;
CFragConnectionID connID;
FSSpec fileSpec;
} TclMacLoadInfo;
static int TryToLoad(Tcl_Interp *interp, TclMacLoadInfo *loadInfo,
CONST char *sym /* native */)
/*
*----------------------------------------------------------------------
*
* TclpDlopen --
*
* This procedure is called to carry out dynamic loading of binary
* code for the Macintosh. This implementation is based on the
* Code Fragment Manager & will not work on other systems.
*
* Results:
* The result is TCL_ERROR, and an error message is left in
* the interp's result.
*
* Side effects:
* New binary code is loaded.
*
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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. */
{
OSErr err;
FSSpec fileSpec;
Tcl_DString ds;
CONST char *native;
TclMacLoadInfo *loadInfo;
native = Tcl_FSGetNativePath(pathPtr);
err = FSpLocationFromPath(strlen(native), native, &fileSpec);
if (err != noErr) {
Tcl_SetResult(interp, "could not locate shared library", TCL_STATIC);
return TCL_ERROR;
}
loadInfo = (TclMacLoadInfo *) ckalloc(sizeof(TclMacLoadInfo));
loadInfo->loaded = 0;
loadInfo->fileSpec = fileSpec;
loadInfo->connID = NULL;
if (TryToLoad(interp, loadInfo, NULL) != TCL_OK) {
ckfree(loadInfo);
return TCL_ERROR;
}
*loadHandle = (Tcl_LoadHandle)loadInfo;
*unloadProcPtr = &TclpUnloadFile;
return TCL_OK;
}
/*
* See the comments about 'struct TclMacLoadInfo' above. This
* function ensures the appropriate library or symbol is
* loaded.
*/
static int
TryToLoad(Tcl_Interp *interp, TclMacLoadInfo *loadInfo,
CONST char *sym /* native */)
{
CFragConnectionID connID;
Ptr dummy;
short fragFileRef, saveFileRef;
Handle fragResource;
UInt32 offset = 0;
UInt32 length = kCFragGoesToEOF;
Str255 errName;
StringPtr fragName=NULL;
if (loadInfo->loaded == 1) {
return TCL_OK;
}
/*
* See if this fragment has a 'cfrg' resource. It will tell us where
* to look for the fragment in the file. If it doesn't exist we will
* assume we have a ppc frag using the whole data fork. If it does
* exist we find the frag that matches the one we are looking for and
* get the offset and size from the resource.
*/
saveFileRef = CurResFile();
SetResLoad(false);
fragFileRef = FSpOpenResFile(&fileSpec, fsRdPerm);
SetResLoad(true);
if (fragFileRef != -1) {
if (sym != NULL) {
UseResFile(fragFileRef);
fragResource = Get1Resource(kCFragResourceType, kCFragResourceID);
HLock(fragResource);
if (ResError() == noErr) {
CfrgItem* srcItem;
long itemCount, index;
Ptr itemStart;
itemCount = (*(CfrgHeaderPtrHand)fragResource)->itemCount;
itemStart = &(*(CfrgHeaderPtrHand)fragResource)->arrayStart;
for (index = 0; index < itemCount;
index++, itemStart += srcItem->itemSize) {
srcItem = (CfrgItem*)itemStart;
if (srcItem->archType != OUR_ARCH_TYPE) continue;
if (!strncasecmp(sym, (char *) srcItem->name + 1,
strlen(sym))) {
offset = srcItem->codeOffset;
length = srcItem->codeLength;
fragName=srcItem->name;
}
}
}
}
/*
* Close the resource file. If the extension wants to reopen the
* resource fork it should use the tclMacLibrary.c file during it's
* construction.
*/
HUnlock(fragResource);
ReleaseResource(fragResource);
CloseResFile(fragFileRef);
UseResFile(saveFileRef);
if (sym == NULL) {
/* We just return */
return TCL_OK;
}
}
/*
* Now we can attempt to load the fragment using the offset & length
* obtained from the resource. We don't worry about the main entry point
* as we are going to search for specific entry points passed to us.
*/
err = GetDiskFragment(&fileSpec, offset, length, fragName,
kLoadCFrag, &connID, &dummy, errName);
if (err != fragNoErr) {
p2cstr(errName);
Tcl_AppendResult(interp, "couldn't load file \"",
Tcl_GetString(pathPtr),
"\": ", errName, (char *) NULL);
return TCL_ERROR;
}
loadInfo->connID = connID;
loadInfo->loaded = 1;
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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
Tcl_DString ds;
Tcl_PackageInitProc *proc=NULL;
TclMacLoadInfo *loadInfo = (TclMacLoadInfo *)loadHandle;
Str255 symbolName;
CFragSymbolClass symClass;
OSErr err;
if (loadInfo->loaded == 0) {
int res;
/*
* First thing we must do is infer the package name from the
* sym variable. We do this by removing the '_Init'.
*/
Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
Tcl_DStringSetLength(&ds, Tcl_DStringLength(&ds) - 5);
res = TryToLoad(interp, loadInfo, Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (res != TCL_OK) {
return NULL;
}
}
Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
strcpy((char *) symbolName + 1, Tcl_DStringValue(&ds));
symbolName[0] = (unsigned) Tcl_DStringLength(&ds);
err = FindSymbol(loadInfo->connID, symbolName, (Ptr *) &proc, &symClass);
Tcl_DStringFree(&ds);
if (err != fragNoErr || symClass == kDataCFragSymbol) {
Tcl_SetResult(interp,
"could not find Initialization routine in library",
TCL_STATIC);
return NULL;
}
return proc;
}
/*
*----------------------------------------------------------------------
*
* TclpUnloadFile --
*
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 | * Side effects: * Does nothing. Can anything be done? * *---------------------------------------------------------------------- */ void | | | | > > | > > | 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 |
* Side effects:
* Does nothing. Can anything be done?
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
TclMacLoadInfo *loadInfo = (TclMacLoadInfo *)loadHandle;
if (loadInfo->loaded) {
CloseConnection((CFragConnectionID*) &(loadInfo->connID));
}
ckfree(loadInfo);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ |
Changes to mac/tclMacTest.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclMacTest.c -- * * Contains commands for platform specific tests for * the Macintosh platform. * * 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 | /* * tclMacTest.c -- * * Contains commands for platform specific tests for * the Macintosh platform. * * 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: tclMacTest.c,v 1.4.28.1 2002/08/20 20:25:27 das Exp $ */ #define TCL_TEST #define USE_COMPAT_CONST #include "tclInt.h" #include "tclMacInt.h" #include "tclMacPort.h" #include "Files.h" #include <Errors.h> #include <Resources.h> #include <Script.h> |
| ︙ | ︙ |
Changes to macosx/Tcl.pbproj/jingham.pbxuser.
1 2 3 4 5 6 7 8 9 10 11 |
// !$*UTF8*$!
{
00E2F845016E82EB0ACA28DC = {
activeBuildStyle = 00E2F847016E82EB0ACA28DC;
activeTarget = F50DC359017027D801DC9062;
addToTargets = (
00E2F84C016E8B780ACA28DC,
);
breakpoints = (
);
perUserDictionary = {
| > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
// !$*UTF8*$!
{
005751AA02FB00930AC916F0 = {
fRef = 005751AB02FB00930AC916F0;
isa = PBXTextBookmark;
name = "DefaultsDoc.rtf: 30";
rLen = 32;
rLoc = 2777;
rType = 0;
vrLen = 1334;
vrLoc = 2136;
};
005751AB02FB00930AC916F0 = {
isa = PBXFileReference;
name = DefaultsDoc.rtf;
path = "/Developer/Applications/Project Builder.app/Contents/Resources/DefaultsDoc.rtf";
refType = 0;
};
00E2F845016E82EB0ACA28DC = {
activeBuildStyle = 00E2F847016E82EB0ACA28DC;
activeTarget = F50DC359017027D801DC9062;
addToTargets = (
00E2F84C016E8B780ACA28DC,
);
breakpoints = (
);
perUserDictionary = {
PBXPerProjectTemplateStateSaveDate = 49920633;
"PBXTemplateGeometry-F5314676015831810DCA290F" = {
ContentSize = "{789, 551}";
LeftSlideOut = {
Collapsed = NO;
Frame = "{{0, 23}, {789, 528}}";
Split0 = {
ActiveTab = 2;
Collapsed = NO;
Frame = "{{0, 0}, {789, 528}}";
Split0 = {
Frame = "{{0, 204}, {789, 324}}";
};
SplitCount = 1;
Tab0 = {
Debugger = {
Collapsed = NO;
Frame = "{{0, 0}, {952, 321}}";
Split0 = {
Frame = "{{0, 24}, {952, 297}}";
Split0 = {
Frame = "{{0, 0}, {468, 297}}";
};
Split1 = {
DebugVariablesTableConfiguration = (
Name,
123,
Value,
85,
Summary,
241.123,
);
Frame = "{{477, 0}, {475, 297}}";
};
SplitCount = 2;
};
SplitCount = 1;
Tab0 = {
Frame = "{{0, 0}, {100, 50}}";
};
Tab1 = {
Frame = "{{0, 0}, {100, 50}}";
};
TabCount = 2;
TabsVisible = YES;
};
Frame = "{{0, 0}, {952, 321}}";
LauncherConfigVersion = 7;
};
Tab1 = {
Frame = "{{0, 0}, {781, 452}}";
LauncherConfigVersion = 3;
Runner = {
Frame = "{{0, 0}, {781, 452}}";
};
};
Tab2 = {
BuildMessageFrame = "{{0, 0}, {791, 191}}";
BuildTranscriptFrame = "{{0, 200}, {791, 0}}";
Frame = "{{0, 0}, {789, 198}}";
};
Tab3 = {
Frame = "{{0, 0}, {612, 295}}";
};
TabCount = 4;
TabsVisible = NO;
};
SplitCount = 1;
Tab0 = {
Frame = "{{0, 0}, {300, 533}}";
GroupTreeTableConfiguration = (
TargetStatusColumn,
18,
MainColumn,
267,
);
};
Tab1 = {
ClassesFrame = "{{0, 0}, {280, 398}}";
ClassesTreeTableConfiguration = (
PBXBookColumnIdentifier,
20,
PBXClassColumnIdentifier,
237,
);
Frame = "{{0, 0}, {278, 659}}";
MembersFrame = "{{0, 407}, {280, 252}}";
MembersTreeTableConfiguration = (
PBXBookColumnIdentifier,
20,
PBXMethodColumnIdentifier,
236,
);
};
Tab2 = {
Frame = "{{0, 0}, {200, 100}}";
};
Tab3 = {
Frame = "{{0, 0}, {200, 100}}";
TargetTableConfiguration = (
ActiveObject,
16,
ObjectNames,
202.296,
);
};
Tab4 = {
BreakpointsTreeTableConfiguration = (
breakpointColumn,
197,
enabledColumn,
31,
);
Frame = "{{0, 0}, {250, 100}}";
};
TabCount = 5;
TabsVisible = NO;
};
StatusViewVisible = YES;
Template = F5314676015831810DCA290F;
ToolbarVisible = YES;
WindowLocation = "{7, 385}";
};
PBXWorkspaceContents = (
{
LeftSlideOut = {
Split0 = {
Split0 = {
NavContent0 = {
bookmark = 005751AA02FB00930AC916F0;
history = (
F5BFE56402F8B7A901DC9062,
F5BFE56702F8B7A901DC9062,
00F4D9CE02F9BA490AC916F0,
);
prevStack = (
F5BFE56A02F8B7A901DC9062,
);
};
NavCount = 1;
NavGeometry0 = {
Frame = "{{0, 0}, {571, 548}}";
NavBarVisible = YES;
};
};
SplitCount = 1;
Tab0 = {
Debugger = {
Split0 = {
SplitCount = 2;
};
SplitCount = 1;
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 | }; TabCount = 5; TabsVisible = YES; }; StatusViewVisible = YES; Template = 64ABBB4501FA494900185B06; ToolbarVisible = YES; | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > | | > | | > > > > > > > > > > > > > > > > | | | | | | > | | < > > | > > | | | | | | | | | | | 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 |
};
TabCount = 5;
TabsVisible = YES;
};
StatusViewVisible = YES;
Template = 64ABBB4501FA494900185B06;
ToolbarVisible = YES;
WindowLocation = "{77, 330}";
},
);
PBXWorkspaceStateSaveDate = 49920633;
};
perUserProjectItems = {
005751AA02FB00930AC916F0 = 005751AA02FB00930AC916F0;
00F4D9CE02F9BA490AC916F0 = 00F4D9CE02F9BA490AC916F0;
F5BFE56402F8B7A901DC9062 = F5BFE56402F8B7A901DC9062;
F5BFE56702F8B7A901DC9062 = F5BFE56702F8B7A901DC9062;
F5BFE56A02F8B7A901DC9062 = F5BFE56A02F8B7A901DC9062;
};
projectwideBuildSettings = {
OBJROOT = "/Volumes/TheCloset/jingham/tcl-tk/source/tcl-merge/Objects";
SYMROOT = "/Volumes/TheCloset/jingham/tcl-tk/source/tcl-merge/Products";
};
wantsIndex = 1;
wantsSCM = 1;
};
00E2F84B016E8A830ACA28DC = {
activeExec = 0;
};
00E2F84C016E8B780ACA28DC = {
activeExec = 0;
};
00E2F84E016E92110ACA28DC = {
activeExec = 0;
};
00F4D9CE02F9BA490AC916F0 = {
fRef = 00F4D9CF02F9BA4A0AC916F0;
isa = PBXTextBookmark;
name = "DefaultsDoc.rtf: 30";
rLen = 32;
rLoc = 2777;
rType = 0;
vrLen = 1334;
vrLoc = 2136;
};
00F4D9CF02F9BA4A0AC916F0 = {
isa = PBXFileReference;
name = DefaultsDoc.rtf;
path = "/Developer/Applications/Project Builder.app/Contents/Resources/DefaultsDoc.rtf";
refType = 0;
};
F50DC359017027D801DC9062 = {
activeExec = 0;
};
F5BFE56402F8B7A901DC9062 = {
fRef = F5BFE56E02F8B7AA01DC9062;
isa = PBXTextBookmark;
name = "stat.h: 1";
rLen = 0;
rLoc = 0;
rType = 0;
vrLen = 1666;
vrLoc = 3618;
};
F5BFE56702F8B7A901DC9062 = {
fRef = F5F24F6E016ECAA401DC9062;
isa = PBXTextBookmark;
name = "tcl.h: 397";
rLen = 6;
rLoc = 11199;
rType = 0;
vrLen = 1293;
vrLoc = 10644;
};
F5BFE56A02F8B7A901DC9062 = {
fRef = F5F24F6E016ECAA401DC9062;
isa = PBXTextBookmark;
name = "tcl.h: 397";
rLen = 6;
rLoc = 11199;
rType = 0;
vrLen = 1293;
vrLoc = 10644;
};
F5BFE56E02F8B7AA01DC9062 = {
isa = PBXFileReference;
name = stat.h;
path = /usr/include/sys/stat.h;
refType = 0;
};
}
|
Changes to macosx/Tcl.pbproj/project.pbxproj.
1 2 3 4 5 6 7 8 |
// !$*UTF8*$!
{
archiveVersion = 1;
classes = {
};
objectVersion = 38;
objects = {
00530A0D0173C8270ACA28DC = {
| | < < > | < < > | 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 |
// !$*UTF8*$!
{
archiveVersion = 1;
classes = {
};
objectVersion = 38;
objects = {
00530A0D0173C8270ACA28DC = {
buildActionMask = 12;
files = (
);
generatedFileNames = (
);
isa = PBXShellScriptBuildPhase;
neededFileNames = (
);
shellPath = /bin/sh;
shellScript = "# install to ${INSTALL_ROOT} with optional stripping\ncd ${TEMP_DIR}/..\nif test \"${INSTALL_STRIP}\" = \"YES\"; then\nexport INSTALL_PROGRAM='${INSTALL} ${INSTALL_STRIP_PROGRAM}'\nexport INSTALL_LIBRARY='${INSTALL} ${INSTALL_STRIP_LIBRARY}'\nelse\nexport INSTALL_PROGRAM='${INSTALL}'\nexport INSTALL_LIBRARY='${INSTALL}'\nfi\ngnumake install-binaries install-libraries TCL_LIBRARY=\"@TCL_IN_FRAMEWORK@\" INSTALL_ROOT=${INSTALL_ROOT} SCRIPT_INSTALL_DIR=${INSTALL_ROOT}${LIBDIR}/Resources/Scripts INSTALL_PROGRAM=\"${INSTALL_PROGRAM}\" INSTALL_LIBRARY=\"${INSTALL_LIBRARY}\"";
};
00530A0E0173CC960ACA28DC = {
buildActionMask = 12;
files = (
);
generatedFileNames = (
);
isa = PBXShellScriptBuildPhase;
neededFileNames = (
);
shellPath = /bin/sh;
shellScript = "# fixup Framework structure\ncd ${INSTALL_ROOT}${LIBDIR}\nln -fs Versions/Current/Headers ../..\nmv -f tclConfig.sh Resources\nif test \"${INSTALL_STRIP}\" = \"NO\"; then\n\t# assume this is a Development build, keep copy of debug library\n\t# so that Deployment build can be installed alongside subsequently\n\tcp -f ${PRODUCT_NAME} ${PRODUCT_NAME}_debug\nfi";
};
00E2F845016E82EB0ACA28DC = {
buildStyles = (
00E2F847016E82EB0ACA28DC,
00E2F848016E82EB0ACA28DC,
);
isa = PBXProject;
|
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
isa = PBXGroup;
refType = 4;
};
00E2F847016E82EB0ACA28DC = {
buildRules = (
);
buildSettings = {
| > | < < | < | < | | | > < < | | | < | < < > < < < | | 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 |
isa = PBXGroup;
refType = 4;
};
00E2F847016E82EB0ACA28DC = {
buildRules = (
);
buildSettings = {
EXTRA_CONFIGURE_FLAGS = "--enable-symbols";
INSTALL_STRIP = NO;
};
isa = PBXBuildStyle;
name = Development;
};
00E2F848016E82EB0ACA28DC = {
buildRules = (
);
buildSettings = {
INSTALL_STRIP = YES;
};
isa = PBXBuildStyle;
name = Deployment;
};
00E2F84A016E8A830ACA28DC = {
children = (
00E2F84D016E92110ACA28DC,
);
isa = PBXGroup;
name = Products;
refType = 4;
};
00E2F84B016E8A830ACA28DC = {
buildArgumentsString = "-c \"${SRCROOT}/../unix/configure --prefix=/usr --mandir=/usr/share/man --libdir=${LIBDIR} --includedir=${LIBDIR}/Headers --enable-threads --enable-framework ${EXTRA_CONFIGURE_FLAGS};\\\nmkdir -p Tcl.framework; ln -fs ../Tcl Tcl.framework/Tcl\"";
buildPhases = (
);
buildSettings = {
EXTRA_CONFIGURE_FLAGS = "";
FRAMEWORK_VERSION = 8.4;
INSTALL_PATH = /Library/Frameworks;
LIBDIR = "/Library/Frameworks/Tcl.framework/Versions/${FRAMEWORK_VERSION}";
PRODUCT_NAME = Configure;
};
buildToolPath = /bin/sh;
buildWorkingDirectory = "${TEMP_DIR}/..";
dependencies = (
);
isa = PBXLegacyTarget;
name = Configure;
productName = Configure;
settingsToExpand = 6;
settingsToPassInEnvironment = 287;
settingsToPassOnCommandLine = 280;
shouldUseHeadermap = 0;
};
00E2F84C016E8B780ACA28DC = {
buildArgumentsString = "TCL_LIBRARY=\"@TCL_IN_FRAMEWORK@\" ${EXTRA_MAKE_FLAGS}";
buildPhases = (
);
buildSettings = {
EXTRA_MAKE_FLAGS = "";
FRAMEWORK_VERSION = 8.4;
INSTALL_PATH = /Library/Frameworks;
LIBDIR = "/Library/Frameworks/Tcl.framework/Versions/${FRAMEWORK_VERSION}";
PRODUCT_NAME = Tcl;
};
buildToolPath = /usr/bin/gnumake;
buildWorkingDirectory = "${TEMP_DIR}/..";
dependencies = (
);
isa = PBXLegacyTarget;
name = Make;
productName = Make;
settingsToExpand = 6;
settingsToPassInEnvironment = 287;
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 155 156 |
};
00E2F84E016E92110ACA28DC = {
buildPhases = (
F50DC36A01703B7301DC9062,
F50DC367017033D701DC9062,
F50DC3680170344801DC9062,
00E2F84F016E92110ACA28DC,
00530A0D0173C8270ACA28DC,
00530A0E0173CC960ACA28DC,
| > < < < | | | < < < < < < < < | 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 |
};
00E2F84E016E92110ACA28DC = {
buildPhases = (
F50DC36A01703B7301DC9062,
F50DC367017033D701DC9062,
F50DC3680170344801DC9062,
00E2F84F016E92110ACA28DC,
F5BE9BBF02FB5974016F146B,
00530A0D0173C8270ACA28DC,
00530A0E0173CC960ACA28DC,
F59AE5E3017AC67A01DC9062,
);
buildSettings = {
DSTROOT = "${TEMP_DIR}";
EXTRA_MAKE_INSTALL_FLAGS = "";
FRAMEWORK_VERSION = 8.4;
INSTALL_PATH = /Library/Frameworks;
LIBDIR = "/Library/Frameworks/Tcl.framework/Versions/${FRAMEWORK_VERSION}";
PRODUCT_NAME = Tcl;
WRAPPER_EXTENSION = framework;
};
dependencies = (
);
isa = PBXFrameworkTarget;
name = TclLibrary;
productInstallPath = /Library/Frameworks;
|
| ︙ | ︙ | |||
196 197 198 199 200 201 202 | <key>CFBundleIconFile</key> <string></string> <key>CFBundleIdentifier</key> <string>com.tcltk.tcllibrary</string> <key>CFBundleInfoDictionaryVersion</key> <string>6.0</string> <key>CFBundleName</key> | | | | < < < < < < < < < < < < < < < | 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 |
<key>CFBundleIconFile</key>
<string></string>
<key>CFBundleIdentifier</key>
<string>com.tcltk.tcllibrary</string>
<key>CFBundleInfoDictionaryVersion</key>
<string>6.0</string>
<key>CFBundleName</key>
<string>Tcl Library 8.4b2</string>
<key>CFBundlePackageType</key>
<string>FMWK</string>
<key>CFBundleShortVersionString</key>
<string>libtcl8.4b2</string>
<key>CFBundleSignature</key>
<string>Tcl </string>
<key>CFBundleVersion</key>
<string>8.4b2</string>
</dict>
</plist>
";
shouldUseHeadermap = 0;
};
00E2F84F016E92110ACA28DC = {
buildActionMask = 2147483647;
files = (
);
isa = PBXHeadersBuildPhase;
};
00E2F854016E922C0ACA28DC = {
children = (
F5F24F87016ECAFC01DC9062,
F5F24F88016ECAFC01DC9062,
F5F24F89016ECAFC01DC9062,
F5F24F8A016ECAFC01DC9062,
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
name = Headers;
refType = 4;
};
00E2F85C016E92B00ACA28DC = {
children = (
F5F24FD8016ECC0F01DC9062,
F5F24FD9016ECC0F01DC9062,
| < | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
name = Headers;
refType = 4;
};
00E2F85C016E92B00ACA28DC = {
children = (
F5F24FD8016ECC0F01DC9062,
F5F24FD9016ECC0F01DC9062,
F5F24FDB016ECC0F01DC9062,
F5F24FDC016ECC0F01DC9062,
F5F24FDD016ECC0F01DC9062,
F5F24FDE016ECC0F01DC9062,
F5F24FDF016ECC0F01DC9062,
F5F24FE0016ECC0F01DC9062,
F5F24FE1016ECC0F01DC9062,
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 |
target = 00E2F84E016E92110ACA28DC;
};
F50DC367017033D701DC9062 = {
buildActionMask = 2147483647;
files = (
);
isa = PBXFrameworksBuildPhase;
| < < < | | < < > | > > > > > < < < < < < < < < < < < < < < < < < < < > | | | | | | | 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 |
target = 00E2F84E016E92110ACA28DC;
};
F50DC367017033D701DC9062 = {
buildActionMask = 2147483647;
files = (
);
isa = PBXFrameworksBuildPhase;
};
F50DC3680170344801DC9062 = {
buildActionMask = 2147483647;
files = (
);
isa = PBXResourcesBuildPhase;
};
F50DC36A01703B7301DC9062 = {
buildActionMask = 2147483647;
files = (
);
isa = PBXSourcesBuildPhase;
};
F59AE5E3017AC67A01DC9062 = {
buildActionMask = 8;
files = (
);
generatedFileNames = (
);
isa = PBXShellScriptBuildPhase;
neededFileNames = (
);
shellPath = /bin/sh;
shellScript = "# build html documentation\ncd ${TEMP_DIR}/..\nmake html DISTDIR=${INSTALL_ROOT}${LIBDIR}/Resources/English.lproj/Documentation/Reference\ncd ${INSTALL_ROOT}${LIBDIR}/Resources/English.lproj/Documentation/Reference\nln -fs contents.htm html/index.html\nrm -f ${PRODUCT_NAME}; ln -fs html ${PRODUCT_NAME}";
};
F5A1836F018242A501DC9062 = {
isa = PBXFileReference;
path = tclMacOSXBundle.c;
refType = 4;
};
F5BE9BBF02FB5974016F146B = {
buildActionMask = 2147483647;
files = (
);
generatedFileNames = (
);
isa = PBXShellScriptBuildPhase;
neededFileNames = (
);
shellPath = /bin/sh;
shellScript = "# symolic link hackery to enable 'make install INSTALL_ROOT=${TEMP_DIR}'\n# to build Tcl.framework and tclsh in ${SYMROOT}\ncd ${TEMP_DIR}\nmkdir -p Library; rm -f Library/Frameworks; ln -fs ${SYMROOT} Library/Frameworks\nmkdir -p usr; rm -f usr/bin; ln -fs ${SYMROOT} usr/bin";
};
F5C88655017D604601DC9062 = {
children = (
F5C88656017D604601DC9062,
F5C88657017D60C901DC9062,
F5C88658017D60C901DC9062,
);
isa = PBXGroup;
name = "Header Tools";
refType = 4;
};
F5C88656017D604601DC9062 = {
isa = PBXFileReference;
name = genStubs.tcl;
path = ../tools/genStubs.tcl;
refType = 2;
};
F5C88657017D60C901DC9062 = {
isa = PBXFileReference;
name = tcl.decls;
path = ../generic/tcl.decls;
refType = 2;
};
F5C88658017D60C901DC9062 = {
isa = PBXFileReference;
name = tclInt.decls;
path = ../generic/tclInt.decls;
refType = 2;
};
F5F24F6B016ECAA401DC9062 = {
isa = PBXFileReference;
name = regcustom.h;
path = ../generic/regcustom.h;
refType = 2;
};
|
| ︙ | ︙ | |||
631 632 633 634 635 636 637 |
};
F5F24F78016ECAA401DC9062 = {
isa = PBXFileReference;
name = tclRegexp.h;
path = ../generic/tclRegexp.h;
refType = 2;
};
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 |
};
F5F24F78016ECAA401DC9062 = {
isa = PBXFileReference;
name = tclRegexp.h;
path = ../generic/tclRegexp.h;
refType = 2;
};
F5F24F87016ECAFC01DC9062 = {
isa = PBXFileReference;
name = regc_color.c;
path = ../generic/regc_color.c;
refType = 2;
};
F5F24F88016ECAFC01DC9062 = {
|
| ︙ | ︙ | |||
1219 1220 1221 1222 1223 1224 1225 |
};
F5F24FD9016ECC0F01DC9062 = {
isa = PBXFileReference;
name = tclLoadDyld.c;
path = ../unix/tclLoadDyld.c;
refType = 2;
};
| < < < < < < | 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 |
};
F5F24FD9016ECC0F01DC9062 = {
isa = PBXFileReference;
name = tclLoadDyld.c;
path = ../unix/tclLoadDyld.c;
refType = 2;
};
F5F24FDB016ECC0F01DC9062 = {
isa = PBXFileReference;
name = tclUnixChan.c;
path = ../unix/tclUnixChan.c;
refType = 2;
};
F5F24FDC016ECC0F01DC9062 = {
|
| ︙ | ︙ | |||
1307 1308 1309 1310 1311 1312 1313 |
path = ../unix/tclXtTest.c;
refType = 2;
};
F5F24FEE016ED0DF01DC9062 = {
children = (
F5F24FEF016ED0DF01DC9062,
F5F24FF0016ED0DF01DC9062,
| < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
path = ../unix/tclXtTest.c;
refType = 2;
};
F5F24FEE016ED0DF01DC9062 = {
children = (
F5F24FEF016ED0DF01DC9062,
F5F24FF0016ED0DF01DC9062,
F5F24FF3016ED0DF01DC9062,
F5F24FF4016ED0DF01DC9062,
F5F24FF5016ED0DF01DC9062,
F5F24FF6016ED0DF01DC9062,
F5F24FFA016ED0DF01DC9062,
F5F24FFB016ED0DF01DC9062,
F5F24FFC016ED0DF01DC9062,
F5F24FFE016ED0DF01DC9062,
F5F25001016ED0DF01DC9062,
F5F25002016ED0DF01DC9062,
F5F25003016ED0DF01DC9062,
F5F25005016ED0DF01DC9062,
F5F25007016ED0DF01DC9062,
F5F25008016ED0DF01DC9062,
F5F2500A016ED0DF01DC9062,
);
isa = PBXGroup;
name = Scripts;
refType = 4;
};
F5F24FEF016ED0DF01DC9062 = {
isa = PBXFileReference;
name = auto.tcl;
path = ../library/auto.tcl;
refType = 2;
};
F5F24FF0016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFolderReference;
name = dde;
path = ../library/dde;
refType = 2;
};
F5F24FF3016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFolderReference;
name = encoding;
path = ../library/encoding;
refType = 2;
};
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 |
F5F24FF6016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFolderReference;
name = http1.0;
path = ../library/http1.0;
refType = 2;
};
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
F5F24FF6016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFolderReference;
name = http1.0;
path = ../library/http1.0;
refType = 2;
};
F5F24FFA016ED0DF01DC9062 = {
isa = PBXFileReference;
name = init.tcl;
path = ../library/init.tcl;
refType = 2;
};
F5F24FFB016ED0DF01DC9062 = {
isa = PBXFileReference;
name = ldAout.tcl;
path = ../library/ldAout.tcl;
refType = 2;
};
F5F24FFC016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFolderReference;
name = msgcat;
path = ../library/msgcat;
refType = 2;
};
F5F24FFE016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFolderReference;
name = opt;
path = ../library/opt;
refType = 2;
};
F5F25001016ED0DF01DC9062 = {
isa = PBXFileReference;
name = package.tcl;
path = ../library/package.tcl;
refType = 2;
};
F5F25002016ED0DF01DC9062 = {
isa = PBXFileReference;
name = parray.tcl;
path = ../library/parray.tcl;
refType = 2;
};
F5F25003016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFolderReference;
name = reg;
path = ../library/reg;
refType = 2;
};
F5F25005016ED0DF01DC9062 = {
isa = PBXFileReference;
name = safe.tcl;
path = ../library/safe.tcl;
refType = 2;
};
F5F25007016ED0DF01DC9062 = {
isa = PBXFileReference;
name = tclIndex;
path = ../library/tclIndex;
refType = 2;
};
F5F25008016ED0DF01DC9062 = {
includeInIndex = 0;
isa = PBXFolderReference;
name = tcltest;
path = ../library/tcltest;
refType = 2;
};
F5F2500A016ED0DF01DC9062 = {
isa = PBXFileReference;
name = word.tcl;
path = ../library/word.tcl;
refType = 2;
};
};
rootObject = 00E2F845016E82EB0ACA28DC;
}
|
Changes to macosx/tclMacOSXBundle.c.
| ︙ | ︙ | |||
73 74 75 76 77 78 79 | * libraryVariableName may be set, and the resource file opened. * *---------------------------------------------------------------------- */ int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
* libraryVariableName may be set, and the resource file opened.
*
*----------------------------------------------------------------------
*/
int
Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
CONST char *bundleName,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
{
CFBundleRef bundleRef;
CFStringRef bundleNameRef;
|
| ︙ | ︙ |
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 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 |
README -- Tcl test suite design document.
RCS: @(#) $Id: README,v 1.8.18.1 2002/08/20 20:25:27 das Exp $
Contents:
---------
1. Introduction
2. 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.
You can run the tests in three ways:
(a) type "make test" in ../unix; this will create the tcltest
executable and run all of the tests. At least "make tcltest"
must be run to create the tcltest executable for the other
options.
(b) type "tcltest <testFile> ?<option> <value>?
where the options and values are the configuration options
of the tcltest package.
(c) start up tcltest in this directory, then "source" the test
file (for example, type "source parse.test"). To run all
of the tests, type "source all.tcl". To use the options in
interactive mode, you can set them with the tcltest::configure
command. Set constraints with the tcltest::testConstraints
command.
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
should correspond to the Tcl or C code file that they are testing.
For example, the test file for the C file "tclCmdAH.c" is
"cmdAH.test". Test files that contain black-box tests may not
correspond to any Tcl or C code file so they should match the pattern
"*_bb.test".
Be sure your new test file can be run from any working directory.
Be sure no temporary files are left behind by your test file.
Use [tcltest::makeFile], [tcltest::removeFile], and [tcltest::cleanupTests]
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.
2. 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.
2) VERBOSE values were longer numeric. [configure -verbose] values
are lists of keywords.
3) When you run "make test", the working dir for the test suite is now
the one from which you called "make test", rather than the "tests"
directory. This change allows for both unix and windows test
suites to be run simultaneously without interference with each
other or with existing files. All tests must now run independently
of their working directory.
4) The "all" file is now called "all.tcl"
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).
|
Deleted tests/autoMkindex.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
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 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 |
# 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.12.12.1 2002/08/20 20:25:27 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
makeFile {# Test file for:
# auto_mkindex
#
# This file provides example cases for testing the Tcl autoloading
# facility. Things are much more complicated with namespaces and classes.
# The "auto_mkindex" facility can no longer be built on top of a simple
# regular expression parser. It must recognize constructs like this:
#
# namespace eval foo {
# proc test {x y} { ... }
# namespace eval bar {
# proc another {args} { ... }
# }
# }
#
# Note that procedures and itcl class definitions can be nested inside
# of namespaces.
#
# Copyright (c) 1993-1998 Lucent Technologies, Inc.
# This shouldn't cause any problems
namespace import -force blt::*
# Should be able to handle "proc" definitions, even if they are
# preceded by white space.
proc normal {x y} {return [expr $x+$y]}
proc indented {x y} {return [expr $x+$y]}
#
# Should be able to handle proc declarations within namespaces,
# even if they have explicit namespace paths.
#
namespace eval buried {
proc inside {args} {return "inside: $args"}
namespace export pub_*
proc pub_one {args} {return "one: $args"}
proc pub_two {args} {return "two: $args"}
}
proc buried::within {args} {return "within: $args"}
namespace eval buried {
namespace eval under {
proc neath {args} {return "neath: $args"}
}
namespace eval ::buried {
proc relative {args} {return "relative: $args"}
proc ::top {args} {return "top: $args"}
proc ::buried::explicit {args} {return "explicit: $args"}
}
}
# With proper hooks, we should be able to support other commands
# that create procedures
proc buried::myproc {name body args} {
::proc $name $body $args
}
namespace eval ::buried {
proc mycmd1 args {return "mycmd"}
myproc mycmd2 args {return "mycmd"}
}
::buried::myproc mycmd3 args {return "another"}
proc {buried::my proc} {name body args} {
::proc $name $body $args
}
namespace eval ::buried {
proc mycmd4 args {return "mycmd"}
{my proc} mycmd5 args {return "mycmd"}
}
{::buried::my proc} mycmd6 args {return "another"}
# A correctly functioning [auto_import] won't choke when a child
# namespace [namespace import]s from its parent.
#
namespace eval ::parent::child {
namespace import ::parent::*
}
proc ::parent::child::test {} {}
} autoMkindex.tcl
# Save initial state of auto_mkindex_parser
auto_load auto_mkindex
if {[info exist auto_mkindex_parser::initCommands]} {
set saveCommands $auto_mkindex_parser::initCommands
}
proc AutoMkindexTestReset {} {
global saveCommands
if {[info exist saveCommands]} {
set auto_mkindex_parser::initCommands $saveCommands
} elseif {[info exist auto_mkindex_parser::initCommands]} {
unset auto_mkindex_parser::initCommands
}
}
set result ""
set origDir [pwd]
cd $::tcltest::temporaryDirectory
test autoMkindex-1.1 {remove any existing tclIndex file} {
file delete tclIndex
file exists tclIndex
} {0}
test autoMkindex-1.2 {build tclIndex based on a test file} {
|
| ︙ | ︙ | |||
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 |
return [lindex $list $ix]
} else {
return {}
}
}
list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*]
} "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}"
test autoMkindex-4.1 {platform indenpendant source commands} {
file delete tclIndex
auto_mkindex . pkg/samename.tcl
set f [open tclIndex r]
set dat [split [string trim [read $f]] "\n"]
set len [llength $dat]
set result [lsort [lrange $dat [expr {$len-2}] [expr {$len-1}]]]
close $f
set result
} {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}}
test autoMkindex-5.1 {escape magic tcl chars in general code} {
file delete tclIndex
set result {}
if { ![catch {auto_mkindex . pkg/magicchar.tcl}] } {
set f [open tclIndex r]
set dat [split [string trim [read $f]] "\n"]
set result [lindex $dat end]
close $f
}
set result
} {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]}
test autoMkindex-5.2 {correctly locate auto loaded procs with []} {
file delete tclIndex
set res {}
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 res [$c eval {catch {{[magic mojo proc]}}}]
interp delete $c
}
set res
} 0
# Clean up.
unset result
AutoMkindexTestReset
if {[info exist saveCommands]} {
unset saveCommands
}
rename AutoMkindexTestReset ""
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < | 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 |
return [lindex $list $ix]
} else {
return {}
}
}
list [lvalue $::result *mycmd4*] [lvalue $::result *mycmd5*] [lvalue $::result *mycmd6*]
} "{::buried::mycmd4 $element} {::buried::mycmd5 $element} {mycmd6 $element}"
makeDirectory pkg
makeFile {
package provide football 1.0
namespace eval ::pro:: {
#
# export only public functions.
#
namespace export {[a-z]*}
}
namespace eval ::college:: {
#
# export only public functions.
#
namespace export {[a-z]*}
}
proc ::pro::team {} {
puts "go packers!"
return true
}
proc ::college::team {} {
puts "go badgers!"
return true
}
} [file join pkg samename.tcl]
test autoMkindex-4.1 {platform indenpendant source commands} {
file delete tclIndex
auto_mkindex . pkg/samename.tcl
set f [open tclIndex r]
set dat [split [string trim [read $f]] "\n"]
set len [llength $dat]
set result [lsort [lrange $dat [expr {$len-2}] [expr {$len-1}]]]
close $f
set result
} {{set auto_index(::college::team) [list source [file join $dir pkg samename.tcl]]} {set auto_index(::pro::team) [list source [file join $dir pkg samename.tcl]]}}
removeFile [file join pkg samename.tcl]
makeFile {
set dollar1 "this string contains an unescaped dollar sign -> \\$foo"
set dollar2 "this string contains an escaped dollar sign -> \$foo \\\$foo"
set bracket1 "this contains an unescaped bracket [NoSuchProc]"
set bracket2 "this contains an escaped bracket \[NoSuchProc\]"
set bracket3 "this contains nested unescaped brackets [[NoSuchProc]]"
proc testProc {} {}
} [file join pkg magicchar.tcl]
test autoMkindex-5.1 {escape magic tcl chars in general code} {
file delete tclIndex
set result {}
if { ![catch {auto_mkindex . pkg/magicchar.tcl}] } {
set f [open tclIndex r]
set dat [split [string trim [read $f]] "\n"]
set result [lindex $dat end]
close $f
}
set result
} {set auto_index(testProc) [list source [file join $dir pkg magicchar.tcl]]}
removeFile [file join pkg magicchar.tcl]
makeFile {
proc {[magic mojo proc]} {} {}
} [file join pkg magicchar2.tcl]
test autoMkindex-5.2 {correctly locate auto loaded procs with []} {
file delete tclIndex
set res {}
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 res [$c eval {catch {{[magic mojo proc]}}}]
interp delete $c
}
set res
} 0
removeFile [file join pkg magicchar2.tcl]
removeDirectory pkg
# Clean up.
unset result
AutoMkindexTestReset
if {[info exist saveCommands]} {
unset saveCommands
}
rename AutoMkindexTestReset ""
removeFile autoMkindex.tcl
if {[file exists tclIndex]} {
file delete -force tclIndex
}
cd $origDir
::tcltest::cleanupTests
|
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.12.4.3 2002/08/20 20:25:27 das 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 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}
catch {interp delete test_interp}
|
| ︙ | ︙ | |||
422 423 424 425 426 427 428 |
test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
# If object isn't preserved, errorInfo would be set to
# "foo\n while executing\n\"garbage bytes\"" because the object's
# string would have been freed, leaving garbage bytes for the error
# message.
proc bgerror {args} {set ::x $::errorInfo}
| > | | | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 |
test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
# If object isn't preserved, errorInfo would be set to
# "foo\n while executing\n\"garbage bytes\"" because the object's
# string would have been freed, leaving garbage bytes for the error
# message.
proc bgerror {args} {set ::x $::errorInfo}
set fName [makeFile {} test1]
set f [open $fName w]
fileevent $f writable "fileevent $f writable {}; error foo"
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} {
} {}
|
| ︙ | ︙ | |||
556 557 558 559 560 561 562 |
test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
} {}
test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}
| | | | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 |
test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
} {}
test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}
test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
catch {close $f}
set res [catch {
set f [open |[list [interpreter]] w+]
fconfigure $f -buffering line
puts $f {fconfigure stdout -buffering line}
puts $f continue
puts $f {puts $errorInfo}
puts $f {puts DONE}
set newMsg {}
set msg {}
|
| ︙ | ︙ | |||
582 583 584 585 586 587 588 |
while executing
"continue
"
DONE
}}
test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} {exec} {
| | | | > | | | > | | | > | | | > | 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 |
while executing
"continue
"
DONE
}}
test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} {exec} {
set fName [makeFile {
puts hello
break
} BREAKtest]
set res [list [catch {exec [interpreter] $fName} msg] $msg]
removeFile BREAKtest
regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
set res
} {1 {hello
invoked "break" outside of a loop
while executing
"break"
(file "BREAKtest" line 3)}}
test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} {exec} {
set fName [makeFile {
interp alias {} patch {} info patchlevel
patch
break
} BREAKtest]
set res [list [catch {exec [interpreter] $fName} msg] $msg]
removeFile BREAKtest
regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
set res
} {1 {invoked "break" outside of a loop
while executing
"break"
(file "BREAKtest" line 4)}}
test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} {exec} {
set fName [makeFile {
foo [set a 1] [break]
} BREAKtest]
set res [list [catch {exec [interpreter] $fName} msg] $msg]
removeFile BREAKtest
regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
set res
} {1 {invoked "break" outside of a loop
while executing
"break"
invoked from within
"foo [set a 1] [break]"
(file "BREAKtest" line 2)}}
test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} {exec} {
set fName [makeFile {
return -code return
} BREAKtest]
set res [list [catch {exec [interpreter] $fName} msg] $msg]
removeFile BREAKtest
regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
set res
} {1 {command returned bad code: 2
while executing
"return -code return"
(file "BREAKtest" line 2)}}
|
| ︙ | ︙ |
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 21 22 |
# 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.16.8.3 2002/08/20 20:25:27 das Exp $
set env(LC_TIME) POSIX
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test clock-1.1 {clock tests} {
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
} {1 {bad switch "-bad": must be -format or -gmt}}
test clock-3.11 {clock format tests} {
clock format 123 -format "x"
} x
test clock-3.12 {clock format tests} {
clock format 123 -format ""
} ""
# 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
| > > > > > > > > | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
} {1 {bad switch "-bad": must be -format or -gmt}}
test clock-3.11 {clock format tests} {
clock format 123 -format "x"
} x
test clock-3.12 {clock format tests} {
clock format 123 -format ""
} ""
test clock-3.13 {clock format with non-ASCII character in the format string} {
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
|
| ︙ | ︙ |
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 21 22 23 |
# 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.15.6.3 2002/08/20 20:25:27 das 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]]
global env
set cmdAHwd [pwd]
|
| ︙ | ︙ | |||
38 39 40 41 42 43 44 45 |
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {1 {wrong # args: should be "catch command ?varName?"}}
test cmdAH-2.1 {Tcl_CdObjCmd} {
list [catch {cd foo bar} msg] $msg
} {1 {wrong # args: should be "cd ?dirName?"}}
test cmdAH-2.2 {Tcl_CdObjCmd} {
| > | | | | | | | | | | | | | 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 |
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {1 {wrong # args: should be "catch command ?varName?"}}
test cmdAH-2.1 {Tcl_CdObjCmd} {
list [catch {cd foo bar} msg] $msg
} {1 {wrong # args: should be "cd ?dirName?"}}
set foodir [file join [temporaryDirectory] foo]
test cmdAH-2.2 {Tcl_CdObjCmd} {
file delete -force $foodir
file mkdir $foodir
cd $foodir
set result [file tail [pwd]]
cd ..
file delete $foodir
set result
} foo
test cmdAH-2.3 {Tcl_CdObjCmd} {
global env
set oldpwd [pwd]
set temp $env(HOME)
set env(HOME) $oldpwd
file delete -force $foodir
file mkdir $foodir
cd $foodir
cd ~
set result [string equal [pwd] $oldpwd]
file delete $foodir
set env(HOME) $temp
set result
} 1
test cmdAH-2.4 {Tcl_CdObjCmd} {
global env
set oldpwd [pwd]
set temp $env(HOME)
set env(HOME) $oldpwd
file delete -force $foodir
file mkdir $foodir
cd $foodir
cd
set result [string equal [pwd] $oldpwd]
file delete $foodir
set env(HOME) $temp
set result
} 1
test cmdAH-2.5 {Tcl_CdObjCmd} {
list [catch {cd ~~} msg] $msg
} {1 {user "~" doesn't exist}}
test cmdAH-2.6 {Tcl_CdObjCmd} {
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
} identity
test cmdAH-5.1 {Tcl_FileObjCmd} {
list [catch file msg] $msg
} {1 {wrong # args: should be "file option ?arg ...?"}}
test cmdAH-5.2 {Tcl_FileObjCmd} {
list [catch {file x} msg] $msg
| | | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
} identity
test cmdAH-5.1 {Tcl_FileObjCmd} {
list [catch file msg] $msg
} {1 {wrong # args: should be "file option ?arg ...?"}}
test cmdAH-5.2 {Tcl_FileObjCmd} {
list [catch {file x} msg] $msg
} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-5.3 {Tcl_FileObjCmd} {
list [catch {file exists} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
test cmdAH-5.4 {Tcl_FileObjCmd} {
list [catch {file exists ""} msg] $msg
} {0 0}
|
| ︙ | ︙ | |||
193 194 195 196 197 198 199 200 201 202 203 |
set volumeList [file volumes]
catch [list glob -nocomplain [lindex $volumeList 0]*]
} {0}
test cmdAH-6.4 {Tcl_FileObjCmd: volumes} {pcOnly} {
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}
# attributes
test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} {
| > > > > > > > > > | | | > > > | | 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 |
set volumeList [file volumes]
catch [list glob -nocomplain [lindex $volumeList 0]*]
} {0}
test cmdAH-6.4 {Tcl_FileObjCmd: volumes} {pcOnly} {
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 /
set res [pwd]
cd $dir
set res
} {/}
# attributes
test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} {
set foofile [makeFile abcde foo.file]
catch {file delete -force $foofile}
close [open $foofile w]
set res [catch {file attributes $foofile}]
# We used [makeFile] so we undo with [removeFile]
removeFile $foofile
set res
} {0}
# dirname
if {[info commands testsetplatform] == {}} {
puts "This application hasn't been compiled with the \"testsetplatform\""
puts "command, so I can't test Tcl_FileObjCmd etc."
} else {
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 |
} {1 {user "_bad_user" doesn't exist}}
testsetplatform $platform
}
# readable
| | | | | | | | | | | | | > | | | | | | | | | | | | | | > | | | | | | | | | 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 |
} {1 {user "_bad_user" doesn't exist}}
testsetplatform $platform
}
# readable
set gorpfile [makeFile abcde gorp.file]
set dirfile [makeDirectory dir.file]
if {[info commands testchmod] == {}} {
puts "This application hasn't been compiled with the \"testchmod\""
puts "command, so I can't test Tcl_FileObjCmd etc."
} else {
test cmdAH-16.1 {Tcl_FileObjCmd: readable} {testchmod} {
list [catch {file readable a b} msg] $msg
} {1 {wrong # args: should be "file readable name"}}
testchmod 0444 $gorpfile
test cmdAH-16.2 {Tcl_FileObjCmd: readable} {testchmod} {
file readable $gorpfile
} 1
testchmod 0333 $gorpfile
test cmdAH-16.3 {Tcl_FileObjCmd: readable} {unixOnly notRoot testchmod} {
file reada $gorpfile
} 0
# writable
test cmdAH-17.1 {Tcl_FileObjCmd: writable} {testchmod} {
list [catch {file writable a b} msg] $msg
} {1 {wrong # args: should be "file writable name"}}
testchmod 0555 $gorpfile
test cmdAH-17.2 {Tcl_FileObjCmd: writable} {notRoot testchmod} {
file writable $gorpfile
} 0
testchmod 0222 $gorpfile
test cmdAH-17.3 {Tcl_FileObjCmd: writable} {testchmod} {
file writable $gorpfile
} 1
}
# executable
removeFile $gorpfile
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} {
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} {pcOnly 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
# exists
test cmdAH-19.1 {Tcl_FileObjCmd: exists} {
list [catch {file exists a b} msg] $msg
} {1 {wrong # args: should be "file exists name"}}
test cmdAH-19.2 {Tcl_FileObjCmd: exists} {file exists $gorpfile} 0
test cmdAH-19.3 {Tcl_FileObjCmd: exists} {
file exists [file join [temporaryDirectory] dir.file gorp.file]
} 0
catch {
set gorpfile [makeFile abcde gorp.file]
set dirfile [makeDirectory dir.file]
set subgorp [makeFile 12345 [file join $dirfile gorp.file]]
}
test cmdAH-19.4 {Tcl_FileObjCmd: exists} {
file exists $gorpfile
} 1
test cmdAH-19.5 {Tcl_FileObjCmd: exists} {
file exists $subgorp
} 1
# nativename
if {[info commands testsetplatform] == {}} {
puts "This application hasn't been compiled with the \"testsetplatform\""
puts "command, so I can't test Tcl_FileObjCmd etc."
} else {
|
| ︙ | ︙ | |||
1133 1134 1135 1136 1137 1138 1139 |
} 1
# The test below has to be done in /tmp rather than the current
# directory in order to guarantee (?) a local file system: some
# NFS file systems won't do the stuff below correctly.
test cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} {
| | | | | | | | | | | | 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 |
} 1
# The test below has to be done in /tmp rather than the current
# directory in order to guarantee (?) a local file system: some
# NFS file systems won't do the stuff below correctly.
test cmdAH-19.11 {Tcl_FileObjCmd: exists} {unixOnly notRoot} {
file delete -force /tmp/tcl.foo.dir/file
file delete -force /tmp/tcl.foo.dir
makeDirectory /tmp/tcl.foo.dir
makeFile 12345 /tmp/tcl.foo.dir/file
file attributes /tmp/tcl.foo.dir -permissions 0000
set result [file exists /tmp/tcl.foo.dir/file]
file attributes /tmp/tcl.foo.dir -permissions 0775
removeFile /tmp/tcl.foo.dir/file
removeDirectory /tmp/tcl.foo.dir
set result
} 0
# Stat related commands
catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0765}
# atime
set file [makeFile "data" touch.me]
test cmdAH-20.1 {Tcl_FileObjCmd: atime} {
list [catch {file atime a b c} msg] $msg
} {1 {wrong # args: should be "file atime name ?time?"}}
test cmdAH-20.2 {Tcl_FileObjCmd: atime} {
catch {unset stat}
file stat $gorpfile stat
list [expr {[file mtime $gorpfile] == $stat(mtime)}] \
[expr {[file atime $gorpfile] == $stat(atime)}]
} {1 1}
test cmdAH-20.3 {Tcl_FileObjCmd: atime} {
string tolower [list [catch {file atime _bogus_} msg] \
$msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-20.4 {Tcl_FileObjCmd: atime} {
list [catch {file atime $file notint} msg] $msg
|
| ︙ | ︙ | |||
1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 |
set atime [file atime $file]
after 1100; # pause a sec to notice change in atime
set newatime [clock seconds]
set modatime [file atime $file $newatime]
expr {$newatime == $modatime ? 1 : "$newatime != $modatime"}
} 1
# isdirectory
test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} {
list [catch {file isdirectory a b} msg] $msg
} {1 {wrong # args: should be "file isdirectory name"}}
test cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} {
| > | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set atime [file atime $file]
after 1100; # pause a sec to notice change in atime
set newatime [clock seconds]
set modatime [file atime $file $newatime]
expr {$newatime == $modatime ? 1 : "$newatime != $modatime"}
} 1
removeFile touch.me
# isdirectory
test cmdAH-21.1 {Tcl_FileObjCmd: isdirectory} {
list [catch {file isdirectory a b} msg] $msg
} {1 {wrong # args: should be "file isdirectory name"}}
test cmdAH-21.2 {Tcl_FileObjCmd: isdirectory} {
file isdirectory $gorpfile
} 0
test cmdAH-21.3 {Tcl_FileObjCmd: isdirectory} {
file isd $dirfile
} 1
# isfile
test cmdAH-22.1 {Tcl_FileObjCmd: isfile} {
list [catch {file isfile a b} msg] $msg
} {1 {wrong # args: should be "file isfile name"}}
test cmdAH-22.2 {Tcl_FileObjCmd: isfile} {file isfile $gorpfile} 1
test cmdAH-22.3 {Tcl_FileObjCmd: isfile} {file isfile $dirfile} 0
# lstat and readlink: don't run these tests everywhere, since not all
# sites will have symbolic links
catch {file link -symbolic $linkfile $gorpfile}
test cmdAH-23.1 {Tcl_FileObjCmd: lstat} {
list [catch {file lstat a} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
test cmdAH-23.2 {Tcl_FileObjCmd: lstat} {
list [catch {file lstat a b c} msg] $msg
} {1 {wrong # args: should be "file lstat name varName"}}
test cmdAH-23.3 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
catch {unset stat}
file lstat $linkfile stat
lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-23.4 {Tcl_FileObjCmd: lstat} {unixOnly nonPortable} {
catch {unset stat}
file lstat $linkfile stat
list $stat(nlink) [expr $stat(mode)&0777] $stat(type)
} {1 511 link}
test cmdAH-23.5 {Tcl_FileObjCmd: lstat errors} {nonPortable} {
string tolower [list [catch {file lstat _bogus_ stat} msg] \
$msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-23.6 {Tcl_FileObjCmd: lstat errors} {
catch {unset x}
set x 44
list [catch {file lstat $gorpfile x} msg] $msg $errorCode
} {1 {can't set "x(dev)": variable isn't array} NONE}
catch {unset stat}
# mkdir
set dirA [file join [temporaryDirectory] a]
set dirB [file join [temporaryDirectory] a]
test cmdAH-23.7 {Tcl_FileObjCmd: mkdir} {
catch {file delete -force $dirA}
file mkdir $dirA
set res [file isdirectory $dirA]
file delete $dirA
set res
} {1}
test cmdAH-23.8 {Tcl_FileObjCmd: mkdir} {
catch {file delete -force $dirA}
file mkdir $dirA/b
set res [file isdirectory $dirA/b]
file delete -force $dirA
set res
} {1}
test cmdAH-23.9 {Tcl_FileObjCmd: mkdir} {
catch {file delete -force $dirA}
file mkdir $dirA/b/c
set res [file isdirectory $dirA/b/c]
file delete -force $dirA
set res
} {1}
test cmdAH-23.10 {Tcl_FileObjCmd: mkdir} {
catch {file delete -force $dirA}
catch {file delete -force $dirB}
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
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} {
set f [open $gorpfile w]
puts $f "More text"
set localOld [clock seconds]
close $f
set old [file mtime $gorpfile]
after 2000
set f [open $gorpfile w]
puts $f "More text"
set localNew [clock seconds]
close $f
set new [file mtime $gorpfile]
expr {
($new > $old) && ($localNew > $localOld) &&
(abs(($new-$old) - ($localNew-$localOld)) <= 1)
}
} {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)}]
} {1 1}
test cmdAH-24.4 {Tcl_FileObjCmd: mtime} {
string tolower [list [catch {file mtime _bogus_} msg] $msg \
$errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-24.5 {Tcl_FileObjCmd: mtime} {
# Under Unix, use a file in /tmp to avoid clock skew due to NFS.
# On other platforms, just use a file in the local directory.
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]
|
| ︙ | ︙ | |||
1347 1348 1349 1350 1351 1352 1353 |
test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} {
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
| | | | | | | | > | | | | | | | | | | 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 |
test cmdAH-24.8 {Tcl_FileObjCmd: mtime touch} {
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
removeFile touch.me
# 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} {
file owned $gorpfile
} 1
test cmdAH-25.3 {Tcl_FileObjCmd: owned} {unixOnly notRoot} {
file owned /
} 0
# readlink
test cmdAH-26.1 {Tcl_FileObjCmd: readlink} {
list [catch {file readlink a b} msg] $msg
} {1 {wrong # args: should be "file readlink name"}}
test cmdAH-26.2 {Tcl_FileObjCmd: readlink} {unixOnly nonPortable} {
file readlink $linkfile
} $gorpfile
test cmdAH-26.3 {Tcl_FileObjCmd: readlink errors} {unixOnly 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.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} {pcOnly 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} {
list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-27.2 {Tcl_FileObjCmd: size} {
set oldsize [file size $gorpfile]
set f [open $gorpfile a]
fconfigure $f -translation lf -eofchar {}
puts $f "More text"
close $f
expr {[file size $gorpfile] - $oldsize}
} {10}
test cmdAH-27.3 {Tcl_FileObjCmd: size} {
string tolower [list [catch {file size _bogus_} msg] $msg \
$errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
# stat
catch {testsetplatform $platform}
removeFile $gorpfile
set gorpfile [makeFile "Test string" gorp.file]
catch {file attributes $gorpfile -permissions 0765}
test cmdAH-28.1 {Tcl_FileObjCmd: stat} {
list [catch {file stat _bogus_} msg] $msg $errorCode
} {1 {wrong # args: should be "file stat name varName"} NONE}
test cmdAH-28.2 {Tcl_FileObjCmd: stat} {
list [catch {file stat _bogus_ a b} msg] $msg $errorCode
} {1 {wrong # args: should be "file stat name varName"} NONE}
test cmdAH-28.3 {Tcl_FileObjCmd: stat} {
catch {unset stat}
file stat $gorpfile stat
lsort [array names stat]
} {atime ctime dev gid ino mode mtime nlink size type uid}
test cmdAH-28.4 {Tcl_FileObjCmd: stat} {
catch {unset stat}
file stat $gorpfile stat
list $stat(nlink) $stat(size) $stat(type)
} {1 12 file}
test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} {
catch {unset stat}
file stat $gorpfile stat
expr $stat(mode)&0777
} {501}
test cmdAH-28.6 {Tcl_FileObjCmd: stat} {
string tolower [list [catch {file stat _bogus_ stat} msg] \
$msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
test cmdAH-28.7 {Tcl_FileObjCmd: stat} {
catch {unset x}
set x 44
list [catch {file stat $gorpfile x} msg] $msg $errorCode
} {1 {can't set "x(dev)": variable isn't array} NONE}
test cmdAH-28.8 {Tcl_FileObjCmd: stat} {
# Sign extension of purported unsigned short to int.
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} {pcOnly} {
# stat of root directory was failing.
# don't care about answer, just that test runs.
# relative paths that resolve to root
|
| ︙ | ︙ | |||
1483 1484 1485 1486 1487 1488 1489 |
cd $old
expr {$stat(dev) == 2}
} 0
test cmdAH-28.12 {Tcl_FileObjCmd: stat} {
# stat(mode) with S_IFREG flag was returned as a negative number
# if mode_t was a short instead of an unsigned short.
| | | | | | | | | | > > > > > > | > > > > > > > > > > > > > > | | > | | | | | | | | 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 |
cd $old
expr {$stat(dev) == 2}
} 0
test cmdAH-28.12 {Tcl_FileObjCmd: stat} {
# stat(mode) with S_IFREG flag was returned as a negative number
# if mode_t was a short instead of an unsigned short.
set filename [makeFile "" foo.test]
file stat $filename stat
removeFile $filename
expr {$stat(mode) > 0}
} 1
catch {unset stat}
# type
test cmdAH-29.1 {Tcl_FileObjCmd: type} {
list [catch {file size a b} msg] $msg
} {1 {wrong # args: should be "file size name"}}
test cmdAH-29.2 {Tcl_FileObjCmd: type} {
file type $dirfile
} directory
test cmdAH-29.3.0 {Tcl_FileObjCmd: delete removes link not file} {unixOnly nonPortable} {
set exists [list [file exists $linkfile] [file exists $gorpfile]]
file delete $linkfile
set exists2 [list [file exists $linkfile] [file exists $gorpfile]]
list $exists $exists2
} {{1 1} {0 1}}
test cmdAH-29.3 {Tcl_FileObjCmd: type} {
file type $gorpfile
} file
test cmdAH-29.4 {Tcl_FileObjCmd: type} {unixOnly} {
catch {file delete $linkfile}
# Unlike [exec ln -s], [file link] requires an existing target
file link -symbolic $linkfile $gorpfile
set result [file type $linkfile]
file delete $linkfile
set result
} link
if {[string equal $tcl_platform(platform) "windows"]} {
if {[string index $tcl_platform(osVersion) 0] >= 5 \
&& ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
tcltest::testConstraint linkDirectory 1
} else {
tcltest::testConstraint linkDirectory 0
}
} else {
tcltest::testConstraint linkDirectory 1
}
test cmdAH-29.4.1 {Tcl_FileObjCmd: type} {linkDirectory} {
set tempdir [makeDirectory temp]
set linkdir [file join [temporaryDirectory] link.dir]
file link -symbolic $linkdir $tempdir
set result [file type $linkdir]
file delete $linkdir
removeDirectory $tempdir
set result
} link
test cmdAH-29.5 {Tcl_FileObjCmd: type} {
string tolower [list [catch {file type _bogus_} msg] $msg $errorCode]
} {1 {could not read "_bogus_": no such file or directory} {posix enoent {no such file or directory}}}
# Error conditions
test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} {
list [catch {file gorp x} msg] $msg
} {1 {bad option "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} {
list [catch {file ex x} msg] $msg
} {1 {ambiguous option "ex": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.3 {Tcl_FileObjCmd: error conditions} {
list [catch {file is x} msg] $msg
} {1 {ambiguous option "is": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.4 {Tcl_FileObjCmd: error conditions} {
list [catch {file z x} msg] $msg
} {1 {bad option "z": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.5 {Tcl_FileObjCmd: error conditions} {
list [catch {file read x} msg] $msg
} {1 {ambiguous option "read": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.6 {Tcl_FileObjCmd: error conditions} {
list [catch {file s x} msg] $msg
} {1 {ambiguous option "s": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.7 {Tcl_FileObjCmd: error conditions} {
list [catch {file t x} msg] $msg
} {1 {ambiguous option "t": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}}
test cmdAH-30.8 {Tcl_FileObjCmd: error conditions} {
list [catch {file dirname ~woohgy} msg] $msg
} {1 {user "woohgy" doesn't exist}}
# channels
# In testing 'file channels', we need to make sure that a channel
# created in one interp isn't visible in another.
|
| ︙ | ︙ | |||
1567 1568 1569 1570 1571 1572 1573 |
test cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} {
string equal [file channels] [file channels *]
} {1}
test cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} {
lsort [file channels std*]
} [lsort {stdout stderr stdin}]
| | | 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 |
test cmdAH-31.3 {Tcl_FileObjCmd: channels, globbing} {
string equal [file channels] [file channels *]
} {1}
test cmdAH-31.4 {Tcl_FileObjCmd: channels, globbing} {
lsort [file channels std*]
} [lsort {stdout stderr stdin}]
set newFileId [open $gorpfile w]
test cmdAH-31.5 {Tcl_FileObjCmd: channels} {
set res [file channels $newFileId]
string equal $newFileId $res
} {1}
test cmdAH-31.6 {Tcl_FileObjCmd: channels in other interp} {
# Safe interps start out with no channels
|
| ︙ | ︙ | |||
1624 1625 1626 1627 1628 1629 1630 |
# cleanup
catch {testsetplatform $platform}
catch {unset platform}
# Tcl_ForObjCmd is tested in for.test
| | | | > | | 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 |
# cleanup
catch {testsetplatform $platform}
catch {unset platform}
# Tcl_ForObjCmd is tested in for.test
catch {file attributes $dirfile -permissions 0777}
removeDirectory $dirfile
removeFile $gorpfile
# No idea how well [removeFile] copes with links...
file delete $linkfile
cd $cmdAHwd
::tcltest::cleanupTests
return
|
Changes to tests/cmdInfo.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | # Copyright (c) 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 |
# Copyright (c) 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: cmdInfo.test,v 1.6.4.1 2002/08/20 20:25:27 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::testConstraint testcmdinfo \
[llength [info commands testcmdinfo]]
::tcltest::testConstraint testcmdtoken \
[llength [info commands testcmdtoken]]
test cmdinfo-1.1 {command procedure and clientData} {testcmdinfo} {
testcmdinfo create x1
testcmdinfo get x1
} {CmdProc1 original CmdDelProc1 original :: stringProc}
test cmdinfo-1.2 {command procedure and clientData} {testcmdinfo} {
|
| ︙ | ︙ |
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 43 44 45 46 47 48 49 50 51 52 53 |
# 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.8.10.2 2002/08/20 20:25:27 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
set tcltest::testConstraints(nonLinuxOnly) \
[expr {![string equal Linux $tcl_platform(os)]}]
# 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 nonLinuxOnly} {
# We don't want this test to run on Linux because they do a
# permissions caching trick which causes this to fail. The
# caching is 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]
cd $cwd
file delete -force $foodir
set result
} {1 {error getting working directory name: permission denied}}
# The tests for Tcl_RegexpObjCmd, Tcl_RegsubObjCmd are in regexp.test
# Tcl_RenameObjCmd
|
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
} {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"}}
| | | | | > > | | | | > | > | 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 |
} {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"}}
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
set file [makeFile {
set x 146
error "error in sourced file"
set y $x
} source.file]
set result [list [catch {source $file} msg] $msg $errorInfo]
removeFile source.file
set result
} -match glob -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]
set result [source $file]
removeFile source.file
set result
} result
# Tcl_SplitObjCmd
test cmdMZ-4.1 {Tcl_SplitObjCmd: split errors} {
list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} NONE}
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
# if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"
# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
| | > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# if not UTF-8 aware, result is "a {} {} b qw\xe5 {} N wq"
split "a\u4e4eb qw\u5e4e\x4e wq" " \u4e4e"
} "a b qw\u5e4eN wq"
# The tests for Tcl_StringObjCmd are in string.test
# The tests for Tcl_SubstObjCmd are in subst.test
# The tests for Tcl_SwitchObjCmd are in switch.test
test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} {
list [catch {time} msg] $msg
} {1 {wrong # args: should be "time command ?count?"}}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} {
list [catch {time a b c} msg] $msg
} {1 {wrong # args: should be "time command ?count?"}}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} {
list [catch {time a b} msg] $msg
} {1 {expected integer but got "b"}}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} {
regexp {^\d+ microseconds per iteration} [time {format 1}]
} 1
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} {
expr {[lindex [time {after 2}] 0] < [lindex [time {after 1000}] 0]}
} 1
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
while executing
"error foo"
invoked from within
"time {error foo}"}}
# The tests for Tcl_TraceObjCmd and TraceVarProc are in trace.test
# The tests for Tcl_WhileObjCmd are in while.test
# cleanup
::tcltest::cleanupTests
return
|
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 22 23 24 |
# 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.13.2.3 2002/08/20 20:25:27 das 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.
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
|
| ︙ | ︙ | |||
68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
catch {unset a}
proc p {} {
set ::a(1) 1
return $::a($::a(1))
}
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {1 1 1}
test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} {
catch {unset a}
set a(1) xyzzyx
proc p {} {
global a
catch {set x 123} a(1)
| > > > > > > > > > | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
catch {unset a}
proc p {} {
set ::a(1) 1
return $::a($::a(1))
}
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {1 1 1}
test compile-2.5 {TclCompileDollarVar: global array, called as ${arrName(0)}} {
catch {unset a}
proc p {} {
global a
set a(1) 1
return ${a(1)}$::a(1)$a(1)
}
list [p] $::a(1) [expr {[lsearch -exact [info globals] a] != 0}]
} {111 1 1}
test compile-3.1 {TclCompileCatchCmd: only catch cmds with scalar vars are compiled inline} {
catch {unset a}
set a(1) xyzzyx
proc p {} {
global a
catch {set x 123} a(1)
|
| ︙ | ︙ | |||
252 253 254 255 256 257 258 | # # Special section for tests of tclLiteral.c # The following tests check for incorrect memory handling in # TclReleaseLiteral. They are only effective when tcl is compiled # with TCL_MEM_DEBUG # # Special test for leak on interp delete [Bug 467523]. | | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
#
# Special section for tests of tclLiteral.c
# The following tests check for incorrect memory handling in
# TclReleaseLiteral. They are only effective when tcl is compiled
# with TCL_MEM_DEBUG
#
# Special test for leak on interp delete [Bug 467523].
::tcltest::testConstraint exec [llength [info commands exec]]
::tcltest::testConstraint memDebug [llength [info commands memory]]
test compile-12.1 {testing literal leak on interp delete} {memDebug} {
proc getbytes {} {
set lines [split [memory info] "\n"]
lindex [lindex $lines 3] 3
}
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
set tmp $end
set end [getbytes]
}
rename getbytes {}
set leak [expr {$end - $tmp}]
} 0
# Special test for a memory error in a preliminary fix of [Bug 467523].
| | > | | | | | | 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 |
set tmp $end
set end [getbytes]
}
rename getbytes {}
set leak [expr {$end - $tmp}]
} 0
# Special test for a memory error in a preliminary fix of [Bug 467523].
# It requires executing a helpfile. Presumably the child process is
# used because when this test fails, it crashes.
test compile-12.2 {testing error on literal deletion} {memDebug exec} {
makeFile {
for {set i 0} {$i < 5} {incr i} {
namespace eval bar {}
namespace delete bar
}
puts 0
} source.file
set res [catch {
exec [interpreter] source.file
}]
catch {removeFile source.file}
set res
} 0
# 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} {
append body " $i"
}
append body {]; puts OK}
regsub BODY {proc crash {} {BODY}; crash} $body script
list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}
# cleanup
catch {rename p ""}
catch {namespace delete test_ns_compile}
catch {unset x}
catch {unset y}
catch {unset a}
::tcltest::cleanupTests
return
|
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 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
# 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.8.18.2 2002/08/20 20:25:27 das Exp $
package require tcltest 2
namespace import -force ::tcltest::*
proc toutf {args} {
global x
lappend x "toutf $args"
}
proc fromutf {args} {
global x
lappend x "fromutf $args"
}
# Some tests require the testencoding command
testConstraint testencoding [llength [info commands testencoding]]
testConstraint exec [llength [info commands exec]]
# TclInitEncodingSubsystem is tested by the rest of this file
# TclFinalizeEncodingSubsystem is not currently tested
test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} {
testencoding create foo toutf fromutf
set old [encoding system]
|
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
fconfigure stdout -encoding jis0208
set x [fconfigure stdout -encoding]
fconfigure stdout -encoding $old
set x
} {jis0208}
test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {
| > | | | < | > > > | | 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 |
fconfigure stdout -encoding jis0208
set x [fconfigure stdout -encoding]
fconfigure stdout -encoding $old
set x
} {jis0208}
test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {
cd [makeDirectory tmp]
makeDirectory [file join tmp encoding]
makeFile {} [file join tmp encoding junk.enc]
makeFile {} [file join tmp encoding junk2.enc]
set path [testencoding path]
testencoding path {}
catch {unset encodings}
catch {unset x}
foreach encoding [encoding names] {
set encodings($encoding) 1
}
testencoding path [list [pwd]]
foreach encoding [encoding names] {
if {![info exists encodings($encoding)]} {
lappend x $encoding
}
}
testencoding path $path
cd [workingDirectory]
removeFile [file join tmp encoding junk2.enc]
removeFile [file join tmp encoding junk.enc]
removeDirectory [file join tmp encoding]
removeDirectory tmp
lsort $x
} {junk junk2}
test encoding-5.1 {Tcl_SetSystemEncoding} {
set old [encoding system]
encoding system jis0208
set x [encoding convertto \u4e4e]
|
| ︙ | ︙ | |||
154 155 156 157 158 159 160 |
append a $a
append a $a
set x [encoding convertfrom jis0208 $a]
list [string length $x] [string index $x 0]
} "512 \u4e4e"
test encoding-8.1 {Tcl_ExternalToUtf} {
| | | | | | | | 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 |
append a $a
append a $a
set x [encoding convertfrom jis0208 $a]
list [string length $x] [string index $x 0]
} "512 \u4e4e"
test encoding-8.1 {Tcl_ExternalToUtf} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary -encoding iso8859-1
puts -nonewline $f "ab\x8c\xc1g"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary -encoding shiftjis
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
set x
} "ab\u4e4eg"
test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
encoding convertto jis0208 "\u543e\u543e\u543e\u543e"
} {8c8c8c8c}
test encoding-9.2 {Tcl_UtfToExternalDString: big buffer} {
set a \u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e\u4e4e
append a $a
append a $a
append a $a
append a $a
append a $a
append a $a
set x [encoding convertto jis0208 $a]
list [string length $x] [string range $x 0 1]
} "1024 8C"
test encoding-10.1 {Tcl_UtfToExternal} {
set f [open [file join [temporaryDirectory] dummy] w]
fconfigure $f -translation binary -encoding shiftjis
puts -nonewline $f "ab\u4e4eg"
close $f
set f [open [file join [temporaryDirectory] dummy] r]
fconfigure $f -translation binary -encoding iso8859-1
set x [read $f]
close $f
file delete [file join [temporaryDirectory] dummy]
set x
} "ab\x8c\xc1g"
proc viewable {str} {
set res ""
foreach c [split $str {}] {
if {[string is print $c] && [string is ascii $c]} {
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 242 |
test encoding-11.5.1 {LoadEncodingFile: escape file} {
viewable [encoding convertto iso2022-jp \u4e4e]
} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
set system [encoding system]
set path [testencoding path]
encoding system identity
testencoding path tmp
| > | > | | | > > | 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 |
test encoding-11.5.1 {LoadEncodingFile: escape file} {
viewable [encoding convertto iso2022-jp \u4e4e]
} [viewable "\x1b\$B8C\x1b(B"]
test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
set system [encoding system]
set path [testencoding path]
encoding system identity
cd [temporaryDirectory]
testencoding path tmp
makeDirectory tmp
makeDirectory [file join tmp encoding]
set f [open [file join tmp encoding splat.enc] w]
fconfigure $f -translation binary
puts $f "abcdefghijklmnop"
close $f
set x [list [catch {encoding convertto splat \u4e4e} msg] $msg]
file delete [file join [temporaryDirectory] tmp encoding splat.enc]
removeDirectory [file join tmp encoding]
removeDirectory tmp
cd [workingDirectory]
testencoding path $path
encoding system $system
set x
} {1 {invalid encoding file "splat"}}
# OpenEncodingFile is fully tested by the rest of the tests in this file.
|
| ︙ | ︙ | |||
321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
set ::iso2022uniData [encoding convertfrom iso2022-jp $::iso2022encData]
set ::iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e
\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a
\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08
\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067
\u3057\u3087\u3046\u304b\uff1f"
set fid [open iso2022.txt w]
fconfigure $fid -encoding binary
puts -nonewline $fid $::iso2022encData
close $fid
test encoding-23.2 {iso2022-jp escape encoding test} {
string equal $::iso2022uniData $::iso2022uniData2
| > | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
set ::iso2022uniData [encoding convertfrom iso2022-jp $::iso2022encData]
set ::iso2022uniData2 "\u79c1\u3069\u3082\u3067\u306f\u3001\u30c1\u30c3\u30d7\u3054\u8cfc\u5165\u6642\u306b\u3054\u767b\u9332\u3044\u305f\u3060\u3044\u305f\u3054\u4f4f\u6240\u3092\u30ad\u30e3\u30c3\u30b7\u30e5\u30a2\u30a6\u30c8\u306e\u969b\u306e
\u5c0f\u5207\u624b\u9001\u4ed8\u5148\u3068\u3057\u3066\u4f7f\u7528\u3057\u3066\u304a\u308a\u307e\u3059\u3002\u6050\u308c\u5165\u308a\u307e\u3059\u304c\u3001\u6b63\u3057\u3044\u4f4f\u6240\u3092\u3054\u767b\u9332\u3057\u306a\u304a
\u304a\u9858\u3044\u3044\u305f\u3057\u307e\u3059\u3002\u307e\u305f\u3001\u5927\u5909\u6050\u7e2e\u3067\u3059\u304c\u3001\u4f4f\u6240\u5909\u66f4\u306e\u3042\u3068\u3001\u65e5\u672c\u8a9e\u30b5\u30fc\u30d3\u30b9\u90e8\uff08
\u0063\u0061\u0073\u0069\u006e\u006f\u005f\u006a\u0061\u0070\u0061\u006e\u0065\u0073\u0065\u0040\u005f\u005f\u005f\u002e\u0063\u006f\u006d\u0020\uff09\u307e\u3067\u3054\u4f4f\u6240\u5909\u66f4\u6e08\u306e\u9023\u7d61\u3092\u3044\u305f\u3060\u3051\u306a\u3044\u3067
\u3057\u3087\u3046\u304b\uff1f"
cd [temporaryDirectory]
set fid [open iso2022.txt w]
fconfigure $fid -encoding binary
puts -nonewline $fid $::iso2022encData
close $fid
test encoding-23.2 {iso2022-jp escape encoding test} {
string equal $::iso2022uniData $::iso2022uniData2
|
| ︙ | ︙ | |||
358 359 360 361 362 363 364 365 |
# read $fis <size> reads size in chars, not raw bytes.
set fid [open iso2022.txt r]
fconfigure $fid -encoding iso2022-jp
set data [read $fid 50]
close $fid
set data
} [string range $::iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
| > | > > | < | > | > | | | | > > | < > | > | | | | | < < | | > | < | 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 |
# read $fis <size> reads size in chars, not raw bytes.
set fid [open iso2022.txt r]
fconfigure $fid -encoding iso2022-jp
set data [read $fid 50]
close $fid
set data
} [string range $::iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
cd [workingDirectory]
test encoding-24.1 {EscapeFreeProc on open channels} -constraints {
exec
} -setup {
# Bug #524674 input
set file [makeFile {
set f [open [file join [file dirname [info script]] iso2022.txt]]
fconfigure $f -encoding iso2022-jp
gets $f
} iso2022.tcl]
} -body {
exec [interpreter] $file
} -cleanup {
removeFile iso2022.tcl
} -result {}
test encoding-24.2 {EscapeFreeProc on open channels} -constraints {
exec
} -setup {
# Bug #524674 output
set file [makeFile {
fconfigure stdout -encoding iso2022-jp
puts ab\u4e4e\u68d9g
exit
} iso2022.tcl]
} -body {
viewable [exec [interpreter] $file]
} -cleanup {
removeFile iso2022.tcl
} -result "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
# Bug #219314 - if we don't free escape encodings correctly on
# channel closure, we go boom
set file [makeFile {
encoding system iso2022-jp
set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
puts $a
} iso2022.tcl]
set f [open "|[list [interpreter] $file]"]
fconfigure $f -encoding iso2022-jp
set count [gets $f line]
close $f
removeFile iso2022.tcl
list $count [viewable $line]
} [list 3 "\u4e4e\u4e5e\u4e5f (\\u4e4e\\u4e5e\\u4e5f)"]
file delete [file join [temporaryDirectory] iso2022.txt]
# EscapeFreeProc, GetTableEncoding, unilen
# are fully tested by the rest of this file
# cleanup
::tcltest::cleanupTests
return
|
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 22 23 24 |
# 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.13.18.3 2002/08/20 20:25:27 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
# of exec.
#
test env-1.1 {propagation of env values to child interpreters} {
|
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
catch {unset env(test)}
expr {$ix >= 0}
} {1}
# Some tests require the "exec" command.
# Skip them if exec is not defined.
| | | < | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
catch {unset env(test)}
expr {$ix >= 0}
} {1}
# Some tests require the "exec" command.
# Skip them if exec is not defined.
testConstraint exec [llength [info commands exec]]
set printenvScript [makeFile {
proc lrem {listname name} {
upvar $listname list
set i [lsearch $list $name]
if {$i >= 0} {
set list [lreplace $list $i $i]
}
return $list
|
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH } {
lrem names $name
}
foreach p $names {
puts "$p=$env($p)"
}
exit
| > | < | > | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY SHLIB_PATH } {
lrem names $name
}
foreach p $names {
puts "$p=$env($p)"
}
exit
} printenv]
# [exec] is required here to see the actual environment received
# by child processes.
proc getenv {} {
global printenvScript tcltest
catch {exec [interpreter] $printenvScript} out
if {$out == "child process exited abnormally"} {
set out {}
}
return $out
}
# Save the current environment variables at the start of the test.
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
# ('saved' env vars)
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH} {
if {[info exists env2($name)]} {
set env($name) $env2($name);
}
}
| | | | | | | | | | | | 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 |
# ('saved' env vars)
foreach name {TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH DISPLAY SHLIB_PATH} {
if {[info exists env2($name)]} {
set env($name) $env2($name);
}
}
test env-2.1 {adding environment variables} {exec} {
getenv
} {}
set env(NAME1) "test string"
test env-2.2 {adding environment variables} {exec} {
getenv
} {NAME1=test string}
set env(NAME2) "more"
test env-2.3 {adding environment variables} {exec} {
getenv
} {NAME1=test string
NAME2=more}
set env(XYZZY) "garbage"
test env-2.4 {adding environment variables} {exec} {
getenv
} {NAME1=test string
NAME2=more
XYZZY=garbage}
set env(NAME2) "new value"
test env-3.1 {changing environment variables} {exec} {
set result [getenv]
unset env(NAME2)
set result
} {NAME1=test string
NAME2=new value
XYZZY=garbage}
test env-4.1 {unsetting environment variables} {exec} {
set result [getenv]
unset env(NAME1)
set result
} {NAME1=test string
XYZZY=garbage}
test env-4.2 {unsetting environment variables} {exec} {
set result [getenv]
unset env(XYZZY)
set result
} {XYZZY=garbage}
test env-4.3 {setting international environment variables} {exec} {
set env(\ua7) \ub6
getenv
} "\ua7=\ub6"
test env-4.4 {changing international environment variables} {exec} {
set env(\ua7) \ua7
getenv
} "\ua7=\ua7"
test env-4.5 {unsetting international environment variables} {exec} {
set env(\ub6) \ua7
unset env(\ua7)
set result [getenv]
unset env(\ub6)
set result
} "\ub6=\ua7"
|
| ︙ | ︙ | |||
240 241 242 243 244 245 246 |
unset env($name)
}
foreach name [array names env2] {
set env($name) $env2($name)
}
# cleanup
| | | 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 |
unset env($name)
}
foreach name [array names env2] {
set env($name) $env2($name)
}
# cleanup
removeFile $printenvScript
::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 20 21 22 23 24 25 26 |
# 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.13.8.2 2002/08/20 20:25:27 das 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]]
test event-1.1 {Tcl_CreateFileHandler, reading} {testfilehandler} {
testfilehandler close
testfilehandler create 0 readable off
testfilehandler clear 0
testfilehandler oneevent
set result ""
|
| ︙ | ︙ | |||
193 194 195 196 197 198 199 200 201 |
rename bgerror {}
set x
} {{a simple error}}
test event-6.1 {BgErrorDeleteProc procedure} {
catch {interp delete foo}
interp create foo
foo eval {
proc bgerror args {
| > > | | < | | | 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 |
rename bgerror {}
set x
} {{a simple error}}
test event-6.1 {BgErrorDeleteProc procedure} {
catch {interp delete foo}
interp create foo
set erroutfile [makeFile Unmodified err.out]
foo eval [list set erroutfile $erroutfile]
foo eval {
proc bgerror args {
global errorInfo erroutfile
set f [open $erroutfile r+]
seek $f 0 end
puts $f "$args $errorInfo"
close $f
}
after 100 {error "first error"}
after 100 {error "second error"}
}
after 100 {interp delete foo}
after 200
update
set f [open $erroutfile r]
set result [read $f]
close $f
removeFile $erroutfile
set result
} {Unmodified
}
test event-7.1 {bgerror / regular} {
set errRes {}
proc bgerror {err} {
|
| ︙ | ︙ | |||
281 282 283 284 285 286 287 |
test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} {
set script {
after 1000 error hello
after 2000 set a 0
vwait a
}
| | | | | | | | | 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 |
test event-7.5 {correct behaviour when there is no bgerror [Bug 219142]} {exec} {
set script {
after 1000 error hello
after 2000 set a 0
vwait a
}
list [catch {exec [interpreter] << $script} errMsg] $errMsg
} {1 {hello
while executing
"error hello"
("after" script)}}
# someday : add a test checking that
# when there is no bgerror, an error msg goes to stderr
# ideally one would use sub interp and transfer a fake stderr
# to it, unfortunatly the current interp tcl API does not allow
# that. the other option would be to use fork a test but it
# then becomes more a file/exec test than a bgerror test.
# end of bgerror tests
catch {rename bgerror {}}
test event-8.1 {Tcl_CreateExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; exit"
flush $child
set result [read $child]
close $child
set result
} {even 6
even 4
odd 41
}
test event-9.1 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
set result
} {even 16
even 6
even 4
}
test event-9.2 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 4"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
set result
} {even 16
even 6
odd 41
}
test event-9.3 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler create 4"
puts $child "testexithandler create 6; testexithandler delete 6"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
set result
} {even 16
even 4
odd 41
}
test event-9.4 {Tcl_DeleteExitHandler procedure} {stdio testexithandler} {
set child [open |[list [interpreter]] r+]
puts $child "testexithandler create 41; testexithandler delete 41"
puts $child "testexithandler create 16; exit"
flush $child
set result [read $child]
close $child
set result
} {even 16
}
test event-10.1 {Tcl_Exit procedure} {stdio} {
set child [open |[list [interpreter]] r+]
puts $child "exit 3"
list [catch {close $child} msg] $msg [lindex $errorCode 0] \
[lindex $errorCode 2]
} {1 {child process exited abnormally} CHILDSTATUS 3}
test event-11.1 {Tcl_VwaitCmd procedure} {
list [catch {vwait} msg] $msg
|
| ︙ | ︙ | |||
401 402 403 404 405 406 407 |
} {{} x-done y-done before q-done}
foreach i [after info] {
after cancel $i
}
test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
| > | | | | | | > | | | | | > | 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 |
} {{} x-done y-done before q-done}
foreach i [after info] {
after cancel $i
}
test event-11.5 {Tcl_VwaitCmd procedure: round robin scheduling, 2 sources} {socket} {
set test1file [makeFile "" test1]
set f1 [open $test1file w]
proc accept {s args} {
puts $s foobar
close $s
}
catch {set s1 [socket -server accept 0]}
after 1000
catch {set s2 [socket 127.0.0.1 [lindex [fconfigure $s1 -sockname] 2]]}
close $s1
set x 0
set y 0
set z 0
fileevent $s2 readable {incr z}
vwait z
fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
fileevent $s2 readable {incr y; if {$x == 3} {set z done}}
vwait z
close $f1
close $s2
removeFile $test1file
list $x $y $z
} {3 3 done}
test event-11.6 {Tcl_VwaitCmd procedure: round robin scheduling, same source} {
set test1file [makeFile "" test1]
set test2file [makeFile "" test2]
set f1 [open $test1file w]
set f2 [open $test2file w]
set x 0
set y 0
set z 0
update
fileevent $f1 writable {incr x; if {$y == 3} {set z done}}
fileevent $f2 writable {incr y; if {$x == 3} {set z done}}
vwait z
close $f1
close $f2
removeFile $test1file
removeFile $test2file
list $x $y $z
} {3 3 done}
test event-12.1 {Tcl_UpdateCmd procedure} {
list [catch {update a b} msg] $msg
} {1 {wrong # args: should be "update ?idletasks?"}}
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 |
# cleanup
foreach i [after info] {
after cancel $i
}
::tcltest::cleanupTests
return
| < < < < < < < < < < < < | 588 589 590 591 592 593 594 |
# 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 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 |
# 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.8.18.2 2002/08/20 20:25:27 das 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]]
set path(echo) [makeFile {
puts -nonewline [lindex $argv 0]
foreach str [lrange $argv 1 end] {
puts -nonewline " $str"
}
puts {}
exit
} echo]
set path(cat) [makeFile {
if {$argv == {}} {
set argv -
}
foreach name $argv {
if {$name == "-"} {
set f stdin
} elseif {[catch {open $name r} f] != 0} {
puts stderr $f
continue
}
while {[eof $f] == 0} {
puts -nonewline [read $f]
}
if {$f != "stdin"} {
close $f
}
}
exit
} cat]
set path(wc) [makeFile {
set data [read stdin]
set lines [regsub -all "\n" $data {} dummy]
set words [regsub -all "\[^ \t\n]+" $data {} dummy]
set chars [string length $data]
puts [format "%8.d%8.d%8.d" $lines $words $chars]
exit
} wc]
set path(sh) [makeFile {
if {[lindex $argv 0] != "-c"} {
error "sh: unexpected arguments $argv"
}
set cmd [lindex $argv 1]
lappend cmd ";"
set newcmd {}
foreach arg $cmd {
if {$arg == ";"} {
eval exec >@stdout 2>@stderr [list [info nameofexecutable]] $newcmd
set newcmd {}
continue
}
if {$arg == "1>&2"} {
set arg >@stderr
}
lappend newcmd $arg
}
exit
} sh]
set path(sleep) [makeFile {
after [expr $argv*1000]
exit
} sleep]
set path(exit) [makeFile {
exit $argv
} exit]
# Basic operations.
test exec-1.1 {basic exec operation} {exec} {
exec [interpreter] $path(echo) a b c
} "a b c"
test exec-1.2 {pipelining} {exec stdio} {
exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(cat)
} "a b c d"
test exec-1.3 {pipelining} {exec stdio} {
set a [exec [interpreter] $path(echo) a b c d | [interpreter] $path(cat) | [interpreter] $path(wc)]
list [scan $a "%d %d %d" b c d] $b $c
} {3 1 4}
set arg {12345678901234567890123456789012345678901234567890}
set arg "$arg$arg$arg$arg$arg$arg"
test exec-1.4 {long command lines} {exec} {
exec [interpreter] $path(echo) $arg
} $arg
set arg {}
# I/O redirection: input from Tcl command.
test exec-2.1 {redirecting input from immediate source} {exec stdio} {
exec [interpreter] $path(cat) << "Sample text"
} {Sample text}
test exec-2.2 {redirecting input from immediate source} {exec stdio} {
exec << "Sample text" [interpreter] $path(cat) | [interpreter] $path(cat)
} {Sample text}
test exec-2.3 {redirecting input from immediate source} {exec stdio} {
exec [interpreter] $path(cat) << "Sample text" | [interpreter] $path(cat)
} {Sample text}
test exec-2.4 {redirecting input from immediate source} {exec stdio} {
exec [interpreter] $path(cat) | [interpreter] $path(cat) << "Sample text"
} {Sample text}
test exec-2.5 {redirecting input from immediate source} {exec} {
exec [interpreter] $path(cat) "<<Joined to arrows"
} {Joined to arrows}
test exec-2.6 {redirecting input from immediate source, with UTF} {exec} {
# If this fails, it may give back:
# "\uC3\uA9\uC3\uA0\uC3\uBC\uC3\uB1"
# If it does, this means that the UTF -> external conversion did not
# 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]
removeFile 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)
exec [interpreter] $path(cat) $path(gorp.file)
} "More simple words"
test exec-3.3 {redirecting output to file} {exec stdio} {
exec > $path(gorp.file) [interpreter] $path(echo) "Different simple words" | [interpreter] $path(cat) | [interpreter] $path(cat)
exec [interpreter] $path(cat) $path(gorp.file)
} "Different simple words"
test exec-3.4 {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.5 {redirecting output to file} {exec} {
exec [interpreter] $path(echo) "First line" >$path(gorp.file)
exec [interpreter] $path(echo) "Second line" >> $path(gorp.file)
exec [interpreter] $path(cat) $path(gorp.file)
} "First line\nSecond line"
test exec-3.6 {redirecting output to file} {exec} {
exec [interpreter] $path(echo) "First line" >$path(gorp.file)
exec [interpreter] $path(echo) "Second line" >>$path(gorp.file)
exec [interpreter] $path(cat) $path(gorp.file)
} "First line\nSecond line"
test exec-3.7 {redirecting output to file} {exec} {
set f [open $path(gorp.file) w]
puts $f "Line 1"
flush $f
exec [interpreter] $path(echo) "More text" >@ $f
exec [interpreter] $path(echo) >@$f "Even more"
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.
removeFile 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)] \
[exec [interpreter] $path(cat) $path(gorp.file)]
} {{} {foo bar}}
test exec-4.3 {redirecting output and stderr to file} {exec} {
exec [interpreter] $path(echo) "first line" > $path(gorp.file)
list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" >>&$path(gorp.file)] \
[exec [interpreter] $path(cat) $path(gorp.file)]
} "{} {first line\nfoo bar}"
test exec-4.4 {redirecting output and stderr to file} {exec} {
set f [open $path(gorp.file) w]
puts $f "Line 1"
flush $f
exec [interpreter] $path(echo) "More text" >&@ $f
exec [interpreter] $path(echo) >&@$f "Even more"
puts $f "Line 3"
close $f
exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nMore text\nEven more\nLine 3"
test exec-4.5 {redirecting output and stderr to file} {exec} {
set f [open $path(gorp.file) w]
puts $f "Line 1"
flush $f
exec >&@ $f [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2"
exec >&@$f [interpreter] $path(sh) -c "$path(echo) xyzzy 1>&2"
puts $f "Line 3"
close $f
exec [interpreter] $path(cat) $path(gorp.file)
} "Line 1\nfoo bar\nxyzzy\nLine 3"
# I/O redirection: input from file.
if { [set ::tcltest::testConstraints(exec)] } {
exec [interpreter] $path(echo) "Just a few thoughts" > $path(gorp.file)
}
test exec-5.1 {redirecting input from file} {exec} {
exec [interpreter] $path(cat) < $path(gorp.file)
} {Just a few thoughts}
test exec-5.2 {redirecting input from file} {exec stdio} {
exec [interpreter] $path(cat) | [interpreter] $path(cat) < $path(gorp.file)
} {Just a few thoughts}
test exec-5.3 {redirecting input from file} {exec stdio} {
exec [interpreter] $path(cat) < $path(gorp.file) | [interpreter] $path(cat)
} {Just a few thoughts}
test exec-5.4 {redirecting input from file} {exec stdio} {
exec < $path(gorp.file) [interpreter] $path(cat) | [interpreter] $path(cat)
} {Just a few thoughts}
test exec-5.5 {redirecting input from file} {exec} {
exec [interpreter] $path(cat) <$path(gorp.file)
} {Just a few thoughts}
test exec-5.6 {redirecting input from file} {exec} {
set f [open $path(gorp.file) r]
set result [exec [interpreter] $path(cat) <@ $f]
close $f
set result
} {Just a few thoughts}
test exec-5.7 {redirecting input from file} {exec} {
set f [open $path(gorp.file) r]
set result [exec <@$f [interpreter] $path(cat)]
close $f
set result
} {Just a few thoughts}
# I/O redirection: standard error through a pipeline.
test exec-6.1 {redirecting stderr through a pipeline} {exec stdio} {
exec [interpreter] $path(sh) -c "$path(echo) foo bar" |& [interpreter] $path(cat)
} "foo bar"
test exec-6.2 {redirecting stderr through a pipeline} {exec stdio} {
exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" |& [interpreter] $path(cat)
} "foo bar"
test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} {
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]
removeFile 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)
} {command input}
# Long input to command and output from command.
set a "0123456789 xxxxxxxxx abcdefghi ABCDEFGHIJK\n"
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
set a [concat $a $a $a $a]
test exec-8.1 {long input and output} {exec} {
exec [interpreter] $path(cat) << $a
} $a
# More than 20 arguments to exec.
test exec-8.2 {long input and output} {exec} {
exec [interpreter] $path(echo) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
} {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23}
# Commands that return errors.
test exec-9.1 {commands returning errors} {exec} {
set x [catch {exec gorp456} msg]
list $x [string tolower $msg] [string tolower $errorCode]
} {1 {couldn't execute "gorp456": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.2 {commands returning errors} {exec} {
string tolower [list [catch {exec [interpreter] echo foo | foo123} msg] $msg $errorCode]
} {1 {couldn't execute "foo123": no such file or directory} {posix enoent {no such file or directory}}}
test exec-9.3 {commands returning errors} {exec stdio} {
list [catch {exec [interpreter] $path(sleep) 1 | [interpreter] $path(exit) 43 | [interpreter] $path(sleep) 1} msg] $msg
} {1 {child process exited abnormally}}
test exec-9.4 {commands returning errors} {exec stdio} {
list [catch {exec [interpreter] $path(exit) 43 | [interpreter] $path(echo) "foo bar"} msg] $msg
} {1 {foo bar
child process exited abnormally}}
test exec-9.5 {commands returning errors} {exec stdio} {
list [catch {exec gorp456 | [interpreter] echo a b c} msg] [string tolower $msg]
} {1 {couldn't execute "gorp456": no such file or directory}}
test exec-9.6 {commands returning errors} {exec} {
list [catch {exec [interpreter] $path(sh) -c "$path(echo) error msg 1>&2"} msg] $msg
} {1 {error msg}}
test exec-9.7 {commands returning errors} {exec stdio} {
list [catch {exec [interpreter] $path(sh) -c "$path(echo) error msg 1>&2" \
| [interpreter] $path(sh) -c "$path(echo) error msg 1>&2"} msg] $msg
} {1 {error msg
error msg}}
set path(err) [makeFile {} err]
test exec-9.8 {commands returning errors} {exec} {
set f [open $path(err) w]
puts $f {
puts stdout out
puts stderr err
}
close $f
list [catch {exec [interpreter] $path(err)} msg] $msg
} {1 {out
err}}
# Errors in executing the Tcl command, as opposed to errors in the
# processes that are invoked.
test exec-10.1 {errors in exec invocation} {exec} {
list [catch {exec} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-10.2 {errors in exec invocation} {exec} {
list [catch {exec | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.3 {errors in exec invocation} {exec} {
list [catch {exec cat |} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.4 {errors in exec invocation} {exec} {
list [catch {exec cat | | cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.5 {errors in exec invocation} {exec} {
list [catch {exec cat | |& cat} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.6 {errors in exec invocation} {exec} {
list [catch {exec cat |&} msg] $msg
} {1 {illegal use of | or |& in command}}
test exec-10.7 {errors in exec invocation} {exec} {
list [catch {exec cat <} msg] $msg
} {1 {can't specify "<" as last word in command}}
test exec-10.8 {errors in exec invocation} {exec} {
list [catch {exec cat >} msg] $msg
} {1 {can't specify ">" as last word in command}}
test exec-10.9 {errors in exec invocation} {exec} {
list [catch {exec cat <<} msg] $msg
} {1 {can't specify "<<" as last word in command}}
test exec-10.10 {errors in exec invocation} {exec} {
list [catch {exec cat >>} msg] $msg
} {1 {can't specify ">>" as last word in command}}
test exec-10.11 {errors in exec invocation} {exec} {
list [catch {exec cat >&} msg] $msg
} {1 {can't specify ">&" as last word in command}}
test exec-10.12 {errors in exec invocation} {exec} {
list [catch {exec cat >>&} msg] $msg
} {1 {can't specify ">>&" as last word in command}}
test exec-10.13 {errors in exec invocation} {exec} {
list [catch {exec cat >@} msg] $msg
} {1 {can't specify ">@" as last word in command}}
test exec-10.14 {errors in exec invocation} {exec} {
list [catch {exec cat <@} msg] $msg
} {1 {can't specify "<@" as last word in command}}
test exec-10.15 {errors in exec invocation} {exec} {
list [catch {exec cat < a/b/c} msg] [string tolower $msg]
} {1 {couldn't read file "a/b/c": no such file or directory}}
test exec-10.16 {errors in exec invocation} {exec} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
test exec-10.17 {errors in exec invocation} {exec} {
list [catch {exec cat << foo > a/b/c} msg] [string tolower $msg]
} {1 {couldn't write file "a/b/c": no such file or directory}}
set f [open $path(gorp.file) w]
test exec-10.18 {errors in exec invocation} {exec} {
list [catch {exec cat <@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for reading}"
close $f
set f [open $path(gorp.file) r]
test exec-10.19 {errors in exec invocation} {exec} {
list [catch {exec cat >@ $f} msg] $msg
} "1 {channel \"$f\" wasn't opened for writing}"
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}}
# 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 [format { catch { exec [info nameofexecutable] %s foo & } } $path(echo)]
close $f
string compare "foo" [exec [interpreter] $path(gorp.file)]
} 0
# Make sure that background commands are properly reaped when
# they eventually die.
if { [set ::tcltest::testConstraints(exec)] } {
exec [interpreter] $path(sleep) 3
}
test exec-12.1 {reaping background processes} \
{exec unixOnly nonPortable} {
for {set i 0} {$i < 20} {incr i} {
exec echo foo > /dev/null &
}
exec sleep 1
catch {exec ps | fgrep "echo foo" | fgrep -v fgrep | wc} msg
lindex $msg 0
} 0
test exec-12.2 {reaping background processes} \
{exec unixOnly nonPortable} {
exec sleep 2 | sleep 2 | sleep 2 &
catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
set x [lindex $msg 0]
exec sleep 3
catch {exec ps | fgrep -i "sleep" | fgrep -i -v fgrep | wc} msg
list $x [lindex $msg 0]
} {3 0}
test exec-12.3 {reaping background processes} \
{exec unixOnly nonPortable} {
exec sleep 1000 &
exec sleep 1000 &
set x [exec ps | fgrep "sleep" | fgrep -v fgrep]
set pids {}
foreach i [split $x \n] {
lappend pids [lindex $i 0]
}
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 |
}
catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg
list $x [lindex $msg 0]
} {2 0}
# Make sure "errorCode" is set correctly.
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < > > | | | | | | | | > > | | | | | | < > | | | | | | | | | | | | | | | | | > | 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 |
}
catch {exec ps | fgrep "sleep" | fgrep -v fgrep | wc} msg
list $x [lindex $msg 0]
} {2 0}
# Make sure "errorCode" is set correctly.
test exec-13.1 {setting errorCode variable} {exec} {
list [catch {exec [interpreter] $path(cat) < a/b/c} msg] [string tolower $errorCode]
} {1 {posix enoent {no such file or directory}}}
test exec-13.2 {setting errorCode variable} {exec} {
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} {
list [catch {exec -keepnewline} msg] $msg
} {1 {wrong # args: should be "exec ?switches? arg ?arg ...?"}}
test exec-14.3 {unknown switch} {exec} {
list [catch {exec -gorp} msg] $msg
} {1 {bad switch "-gorp": must be -keepnewline or --}}
test exec-14.4 {-- switch} {exec} {
list [catch {exec -- -gorp} msg] [string tolower $msg]
} {1 {couldn't execute "-gorp": no such file or directory}}
# Redirecting standard error separately from standard output
test exec-15.1 {standard error redirection} {exec} {
exec [interpreter] $path(echo) "First line" > $path(gorp.file)
list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" 2> $path(gorp.file)] \
[exec [interpreter] $path(cat) $path(gorp.file)]
} {{} {foo bar}}
test exec-15.2 {standard error redirection} {exec stdio} {
list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" \
| [interpreter] $path(echo) biz baz >$path(gorp.file) 2> $path(gorp.file2)] \
[exec [interpreter] $path(cat) $path(gorp.file)] \
[exec [interpreter] $path(cat) $path(gorp.file2)]
} {{} {biz baz} {foo bar}}
test exec-15.3 {standard error redirection} {exec stdio} {
list [exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" \
| [interpreter] $path(echo) biz baz 2>$path(gorp.file) > $path(gorp.file2)] \
[exec [interpreter] $path(cat) $path(gorp.file)] \
[exec [interpreter] $path(cat) $path(gorp.file2)]
} {{} {foo bar} {biz baz}}
test exec-15.4 {standard error redirection} {exec} {
set f [open $path(gorp.file) w]
puts $f "Line 1"
flush $f
exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" 2>@ $f
puts $f "Line 3"
close $f
exec [interpreter] $path(cat) $path(gorp.file)
} {Line 1
foo bar
Line 3}
test exec-15.5 {standard error redirection} {exec} {
exec [interpreter] $path(echo) "First line" > $path(gorp.file)
exec [interpreter] $path(sh) -c "$path(echo) foo bar 1>&2" 2>> $path(gorp.file)
exec [interpreter] $path(cat) $path(gorp.file)
} {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
exec [interpreter] $path(cat) $path(gorp.file)
} {First line
Second line
Third line}
test exec-16.2 {flush output before exec} {exec} {
set f [open $path(gorp.file) w]
puts $f "First line"
exec [interpreter] << {puts stderr {Second line}} >&@ $f > $path(gorp.file2)
puts $f "Third line"
close $f
exec [interpreter] $path(cat) $path(gorp.file)
} {First line
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 $f [format {close stdout
set f [open %s w]
catch {exec [info nameofexecutable] %s foobar &}
exec [info nameofexecutable] %s 2
close $f
} $path(gorp.file) $path(echo) $path(sleep)]
close $f
catch {exec [interpreter] $path(script)} result
set f [open $path(gorp.file) r]
lappend result [read $f]
close $f
set result
} {{foobar
}}
test exec-18.1 { exec cat deals with weird file names} {exec} {
set f "foo\[\{blah"
set path(fooblah) [makeFile {} $f]
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
|
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 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
#
# 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.9.14.2 2002/08/20 20:25:27 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}
::tcltest::testConstraint testobj \
[expr {[info commands testobj] != {} \
&& [info commands testdoubleobj] != {} \
&& [info commands teststringobj] != {} \
&& [info commands testobj] != {}}]
::tcltest::testConstraint longIs32bit \
[expr {int(0x80000000) < 0}]
# Tests for the omnibus TclExecuteByteCode function:
# INST_DONE not tested
# INST_PUSH1 not tested
# INST_PUSH4 not tested
|
| ︙ | ︙ |
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 24 25 26 |
# 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.11.12.3 2002/08/20 20:25:27 das 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"})} {
set gotT1 0
puts "This application hasn't been compiled with the \"T1\" and"
puts "\"T2\" math functions, so I'll skip some of the expr tests."
|
| ︙ | ︙ | |||
895 896 897 898 899 900 901 |
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
if $gotT1 {
test expr-old-34.17 {errors in math functions} {
list [catch {expr T1(4)} msg] $msg
} {1 {too many arguments for math function}}
}
| | | | | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 |
} {1 {integer value too large to represent} {ARITH IOVERFLOW {integer value too large to represent}}}
if $gotT1 {
test expr-old-34.17 {errors in math functions} {
list [catch {expr T1(4)} msg] $msg
} {1 {too many arguments for math function}}
}
test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
expr 0289
} -returnCodes error -match glob -result {*invalid octal number*}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
set x 0289
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.3 {ExprLooksLikeInt procedure} {
list [catch {expr 0289.1} msg] $msg
} {0 289.1}
|
| ︙ | ︙ | |||
934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
list [catch {expr 78e} msg] $msg
} {1 {syntax error in expression "78e"}}
# test for [Bug #542588]
test expr-old-36.11 {ExprLooksLikeInt procedure} {
# define a "too large integer"; this one works also for 64bit arith
set x 665802003400000000000000
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}
if {[info commands testexprlong] == {}} {
puts "This application hasn't been compiled with the \"testexprlong\""
puts "command, so I can't test Tcl_ExprLong etc."
} else {
| > > > > > > > > > > > > > > > > > > > > > > | 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 |
list [catch {expr 78e} msg] $msg
} {1 {syntax error in expression "78e"}}
# test for [Bug #542588]
test expr-old-36.11 {ExprLooksLikeInt procedure} {
# define a "too large integer"; this one works also for 64bit arith
set x 665802003400000000000000
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}
# tests for [Bug #587140]
test expr-old-36.12 {ExprLooksLikeInt procedure} {
set x "10;"
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-36.13 {ExprLooksLikeInt procedure} {
set x " +"
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-36.14 {ExprLooksLikeInt procedure} {
set x "123456789012345678901234567890 "
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}
test expr-old-36.15 {ExprLooksLikeInt procedure} {
set x "099 "
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.16 {ExprLooksLikeInt procedure} {
set x " 0xffffffffffffffffffffffffffffffffffffff "
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use integer value too large to represent as operand of "+"}}
if {[info commands testexprlong] == {}} {
puts "This application hasn't been compiled with the \"testexprlong\""
puts "command, so I can't test Tcl_ExprLong etc."
} else {
|
| ︙ | ︙ |
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 |
# 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.12.12.2 2002/08/20 20:25:27 das 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"})
}]
# procedures used below
proc put_hello_char {c} {
global a
append a [format %c $c]
return $c
|
| ︙ | ︙ | |||
626 627 628 629 630 631 632 |
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} {
catch {expr sin(1} msg
set errorInfo
} {syntax error in expression "sin(1": missing close parenthesis at end of function call
while compiling
"expr sin(1"}
| < | | | | | | < | | | | | | | | | > > | > > > > > > > > > > > > | 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 |
"expr pow(1)"}
test expr-15.6 {CompileMathFuncCall: missing ')'} {
catch {expr sin(1} msg
set errorInfo
} {syntax error in expression "sin(1": missing close parenthesis at end of function call
while compiling
"expr sin(1"}
test expr-15.7 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr 2*T1()
} 246
test expr-15.8 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr T2()*3
} 1035
test expr-15.9 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr T3(21, 37)
} 37
test expr-15.10 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr T3(21.2, 37)
} 37.0
test expr-15.11 {CompileMathFuncCall: call registered math function} {registeredMathFuncs} {
expr T3(-21.2, -17.5)
} -17.5
test expr-15.12 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(21, wide(37))
} 37
test expr=15.13 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(wide(21), 37)
} 37
test expr=15.14 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(wide(21), wide(37))
} 37
test expr-15.15 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(21.0, wide(37))
} 37.0
test expr=15.16 {ExprCallMathFunc: call registered math function} {registeredMathFuncs} {
expr T3(wide(21), 37.0)
} 37.0
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
set i 123
if {[expr 0x$a(VALUE)] & 16} {
set i {}
|
| ︙ | ︙ | |||
763 764 765 766 767 768 769 770 771 772 773 774 775 |
test expr-21.7 {non-numeric boolean literals} {expr !false} 1
test expr-21.8 {non-numeric boolean literals} {expr !true } 0
test expr-21.9 {non-numeric boolean literals} {expr !off } 1
test expr-21.10 {non-numeric boolean literals} {expr !on } 0
test expr-21.11 {non-numeric boolean literals} {expr !no } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes } 0
# cleanup
if {[info exists a]} {
unset a
}
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
test expr-21.7 {non-numeric boolean literals} {expr !false} 1
test expr-21.8 {non-numeric boolean literals} {expr !true } 0
test expr-21.9 {non-numeric boolean literals} {expr !off } 1
test expr-21.10 {non-numeric boolean literals} {expr !on } 0
test expr-21.11 {non-numeric boolean literals} {expr !no } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes } 0
# Test for non-numeric float handling.
#
# These are non-portable because strtod()-support for "Inf" and "NaN"
# is so wildly variable. This sucks...
test expr-22.1 {non-numeric floats} nonPortable {
list [catch {expr {NaN + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.2 {non-numeric floats} nonPortable {
list [catch {expr {Inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.3 {non-numeric floats} nonPortable {
set nan NaN
list [catch {expr {$nan + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.4 {non-numeric floats} nonPortable {
set inf Inf
list [catch {expr {$inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.5 {non-numeric floats} nonPortable {
list [catch {expr NaN} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-22.6 {non-numeric floats} nonPortable {
list [catch {expr Inf} msg] $msg
} {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
|
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 |
# 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.11.8.1 2002/08/20 20:25:27 das 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]]
# Several tests require need to match results against the unix username
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
file mkdir td1
testchmod 000 td1
createfile tf1
set msg [list [catch {file rename tf1 td1} msg] $msg]
testchmod 755 td1
set msg
} {1 {error renaming "tf1" to "td1/tf1": permission denied}}
| | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
file mkdir td1
testchmod 000 td1
createfile tf1
set msg [list [catch {file rename tf1 td1} msg] $msg]
testchmod 755 td1
set msg
} {1 {error renaming "tf1" to "td1/tf1": permission denied}}
test fCmd-6.7 {CopyRenameOneFile: errno != ENOENT} {pcOnly 95} {
cleanup
createfile tf1
list [catch {file rename tf1 $long} msg] $msg
} [subst {1 {error renaming "tf1" to "$long": file name too long}}]
test fCmd-6.8 {CopyRenameOneFile: errno != ENOENT} {macOnly} {
cleanup
createfile tf1
|
| ︙ | ︙ | |||
540 541 542 543 544 545 546 |
file rename tf1 /tmp
glob tf* /tmp/tf*
} {/tmp/tf1}
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \
{unixOnly notRoot xdev} {
cleanup /tmp
file mkdir td1/td2/td3
| | | | > | | > | | > < > | | | 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 |
file rename tf1 /tmp
glob tf* /tmp/tf*
} {/tmp/tf1}
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \
{unixOnly notRoot xdev} {
cleanup /tmp
file mkdir td1/td2/td3
file attributes td1 -permissions 0000
set msg [list [catch {file rename td1 /tmp} msg] $msg]
file attributes td1 -permissions 0755
set msg
} {1 {error renaming "td1": permission denied}}
test fCmd-6.24 {CopyRenameOneFile: error uses original name} \
{unixOnly notRoot} {
cleanup
file mkdir ~/td1/td2
set td1name [file join [file dirname ~] [file tail ~] td1]
file attributes $td1name -permissions 0000
set msg [list [catch {file copy ~/td1 td1} msg] $msg]
file attributes $td1name -permissions 0755
file delete -force ~/td1
set msg
} {1 {error copying "~/td1": permission denied}}
test fCmd-6.25 {CopyRenameOneFile: error uses original name} \
{unixOnly notRoot} {
cleanup
file mkdir td2
file mkdir ~/td1
set td1name [file join [file dirname ~] [file tail ~] td1]
file attributes $td1name -permissions 0000
set msg [list [catch {file copy td2 ~/td1} msg] $msg]
file attributes $td1name -permissions 0755
file delete -force ~/td1
set msg
} {1 {error copying "td2" to "~/td1/td2": permission denied}}
test fCmd-6.26 {CopyRenameOneFile: doesn't use original name} \
{unixOnly notRoot} {
cleanup
file mkdir ~/td1/td2
set td2name [file join [file dirname ~] [file tail ~] td1 td2]
file attributes $td2name -permissions 0000
set msg [list [catch {file copy ~/td1 td1} msg] $msg]
file attributes $td2name -permissions 0755
file delete -force ~/td1
set msg
} "1 {error copying \"~/td1\" to \"td1\": \"[file join [file dirname ~] [file tail ~] td1 td2]\": permission denied}"
test fCmd-6.27 {CopyRenameOneFile: TclpCopyDirectory failed} \
{unixOnly notRoot xdev} {
cleanup /tmp
file mkdir td1/td2/td3
file mkdir /tmp/td1
createfile /tmp/td1/tf1
list [catch {file rename -force td1 /tmp} msg] $msg
} {1 {error renaming "td1" to "/tmp/td1": file already exists}}
test fCmd-6.28 {CopyRenameOneFile: TclpCopyDirectory failed} \
{unixOnly notRoot xdev} {
cleanup /tmp
file mkdir td1/td2/td3
file attributes td1/td2/td3 -permissions 0000
set msg [list [catch {file rename td1 /tmp} msg] $msg]
file attributes td1/td2/td3 -permissions 0755
set msg
} {1 {error renaming "td1" to "/tmp/td1": "td1/td2/td3": permission denied}}
test fCmd-6.29 {CopyRenameOneFile: TclpCopyDirectory passed} \
{unixOnly notRoot xdev} {
cleanup /tmp
file mkdir td1/td2/td3
file rename td1 /tmp
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 |
set result
} {1}
test fCmd-12.8 {renamefile: generic error} {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/dir
| | | | 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 |
set result
} {1}
test fCmd-12.8 {renamefile: generic error} {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/dir
file attributes tfa -permissions 0555
set result [catch {file rename tfa/dir tfa2}]
file attributes tfa -permissions 0777
file delete -force tfa
set result
} {1}
test fCmd-12.9 {renamefile: moving a file across volumes} {unixOnly notRoot} {
catch {file delete -force -- tfa /tmp/tfa}
|
| ︙ | ︙ | |||
1352 1353 1354 1355 1356 1357 1358 |
file delete -force tfa tfa2
set result
} {1}
test fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa/dir/a/b/c
| | | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 |
file delete -force tfa tfa2
set result
} {1}
test fCmd-14.8 {copyfile: copy directory failing} {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa/dir/a/b/c
file attributes tfa/dir -permissions 0000
set r1 [catch {file copy tfa tfa2}]
file attributes tfa/dir -permissions 0777
set result $r1
file delete -force tfa tfa2
set result
} {1}
#
# Coverage tests for TclMkdirCmd()
|
| ︙ | ︙ | |||
1395 1396 1397 1398 1399 1400 1401 |
set result
} {1}
test fCmd-15.4 {TclMakeDirsCmd - stat failing} {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
createfile tfa/file
| | | | 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 |
set result
} {1}
test fCmd-15.4 {TclMakeDirsCmd - stat failing} {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
createfile tfa/file
file attributes tfa -permissions 0000
set result [catch {file mkdir tfa/file}]
file attributes tfa -permissions 0777
file delete -force tfa
set result
} {1}
test fCmd-15.5 {TclMakeDirsCmd: - making a directory several levels deep} \
{notRoot} {
catch {file delete -force -- tfa}
|
| ︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 |
set result [file isdir tfa]
file delete tfa
set result
} {1}
# Coverage tests for TclDeleteFilesCommand()
| | | | | | | 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 |
set result [file isdir tfa]
file delete tfa
set result
} {1}
# Coverage tests for TclDeleteFilesCommand()
test fCmd-16.1 {test the -- argument} {notRoot} {
catch {file delete -force -- tfa}
createfile tfa
file delete -- tfa
file exists tfa
} {0}
test fCmd-16.2 {test the -force and -- arguments} {notRoot} {
catch {file delete -force -- tfa}
createfile tfa
file delete -force -- tfa
file exists tfa
} {0}
test fCmd-16.3 {test bad option} {notRoot} {
catch {file delete -force -- tfa}
createfile tfa
set result [catch {file delete -dog tfa}]
file delete tfa
set result
} {1}
test fCmd-16.4 {test not enough args} {notRoot} {
catch {file delete}
} {1}
test fCmd-16.5 {test not enough args with options} {notRoot} {
catch {file delete --}
} {1}
test fCmd-16.6 {delete: source filename translation failing} {notRoot} {
global env
set temp $env(HOME)
unset env(HOME)
|
| ︙ | ︙ | |||
1502 1503 1504 1505 1506 1507 1508 |
set result
} {1}
test fCmd-16.9 {error while deleting file } {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
createfile tfa/a
| | | | | | | 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 |
set result
} {1}
test fCmd-16.9 {error while deleting file } {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
createfile tfa/a
file attributes tfa -permissions 0555
set result [catch {file delete tfa/a }]
#######
####### If any directory in a tree that is being removed does not
####### have write permission, the process will fail!
####### This is also the case with "rm -rf"
#######
file attributes tfa -permissions 0777
file delete -force tfa
set result
} {1}
test fCmd-16.10 {deleting multiple files} {notRoot} {
catch {file delete -force -- tfa1 tfa2}
createfile tfa1
createfile tfa2
file delete tfa1 tfa2
expr ![file exists tfa1] && ![file exists tfa2]
} {1}
test fCmd-16.11 {TclFileDeleteCmd: removing a nonexistant file} {notRoot} {
catch {file delete -force -- tfa}
file delete tfa
set result 1
} {1}
# More coverage tests for mkpath()
test fCmd-17.1 {mkdir stat failing on target but not ENOENT} {unixOnly notRoot} {
catch {file delete -force -- tfa1}
file mkdir tfa1
file attributes tfa1 -permissions 0555
set result [catch {file mkdir tfa1/tfa2}]
file attributes tfa1 -permissions 0777
file delete -force tfa1
set result
} {1}
test fCmd-17.2 {mkdir several levels deep - relative } {notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa/a/b
|
| ︙ | ︙ | |||
1690 1691 1692 1693 1694 1695 1696 |
} {1}
test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} \
{unixOnly notRoot} {
catch {file delete -force -- tfa1 tfa2 tfa3}
set s [createfile tfa1]
| | | | | | | | | | | | | | 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 |
} {1}
test fCmd-18.12 {TclFileRenameCmd : rename a symbolic link to file} \
{unixOnly notRoot} {
catch {file delete -force -- tfa1 tfa2 tfa3}
set s [createfile tfa1]
file link -symbolic tfa2 tfa1
file rename tfa2 tfa3
set t [file type tfa3]
set result [expr {$t eq "link"}]
file delete tfa1 tfa3
set result
} {1}
test fCmd-18.13 {TclFileRenameCmd : rename a symbolic link to dir} \
{unixOnly notRoot} {
catch {file delete -force -- tfa1 tfa2 tfa3}
file mkdir tfa1
file link -symbolic tfa2 tfa1
file rename tfa2 tfa3
set t [file type tfa3]
set result [expr {$t eq "link"}]
file delete tfa1 tfa3
set result
} {1}
test fCmd-18.14 {TclFileRenameCmd : rename a path with sym link} \
{unixOnly notRoot} {
catch {file delete -force -- tfa1 tfa2 tfa3}
file mkdir tfa1/a/b/c/d
file mkdir tfa2
set f [file join [pwd] tfa1/a/b]
set f2 [file join [pwd] {tfa2/b alias}]
file link -symbolic $f2 $f
file rename {tfa2/b alias/c} tfa3
set r1 [file isdir tfa3]
set r2 [file exists tfa1/a/b/c]
set result [expr $r1 && !$r2]
file delete -force tfa1 tfa2 tfa3
set result
} {1}
test fCmd-18.15 {TclFileRenameCmd : rename a file to a symlink dir} \
{unixOnly notRoot} {
catch {file delete -force -- tfa1 tfa2 tfalink}
file mkdir tfa1
set s [createfile tfa2]
file link -symbolic tfalink tfa1
file rename tfa2 tfalink
set result [checkcontent tfa1/tfa2 $s ]
file delete -force tfa1 tfalink
set result
} {1}
test fCmd-18.16 {TclFileRenameCmd: rename a dangling symlink} {unixOnly notRoot} {
catch {file delete -force -- tfa1 tfalink}
file mkdir tfa1
file link -symbolic tfalink tfa1
file delete tfa1
file rename tfalink tfa2
set result [expr [string compare [file type tfa2] "link"] == 0]
file delete tfa2
set result
} {1}
#
# Coverage tests for TclUnixRmdir
#
test fCmd-19.1 {remove empty directory} {notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file delete tfa
file exists tfa
} {0}
test fCmd-19.2 {rmdir error besides EEXIST} {unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/a
file attributes tfa -permissions 0555
set result [catch {file delete tfa/a}]
file attributes tfa -permissions 0777
file delete -force tfa
set result
} {1}
test fCmd-19.3 {recursive remove} {notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/a
file delete -force tfa
file exists tfa
} {0}
|
| ︙ | ︙ | |||
1799 1800 1801 1802 1803 1804 1805 |
#
test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } \
{unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/a
| | | | 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 |
#
test fCmd-20.1 {TraverseUnixTree : failure opening a subdirectory directory } \
{unixOnly notRoot} {
catch {file delete -force -- tfa}
file mkdir tfa
file mkdir tfa/a
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
|
| ︙ | ︙ | |||
1878 1879 1880 1881 1882 1883 1884 |
set r2 [file isdir [file join tfad2 tfad1]]
set r3 [checkcontent tfa1 $s]
set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]]
file delete -force tfa1 tfad1 tfad2
set result
} {1}
| > > > > > > > > | | | > > > > > > | > > > > > | | | | | | | 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 |
set r2 [file isdir [file join tfad2 tfad1]]
set r3 [checkcontent tfa1 $s]
set result [expr $r1 && $r2 && $r3 && [file isdir tfad1]]
file delete -force tfa1 tfad1 tfad2
set result
} {1}
test fCmd-21.7.1 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot dontCopyLinks} {
file mkdir tfad1
file link -symbolic tfalink tfad1
file delete tfad1
set result [list [catch {file copy tfalink tfalink2} msg] $msg]
file delete -force tfalink tfalink2
set result
} {1 {error copying "tfalink": the target of this link doesn't exist}}
test fCmd-21.7.2 {TclCopyFilesCmd: copy a dangling link} {unixOnly notRoot} {
file mkdir tfad1
file link -symbolic tfalink tfad1
file delete tfad1
file copy tfalink tfalink2
set result [string match [file type tfalink2] link]
file delete tfalink tfalink2
set result
} {1}
test fCmd-21.8.1 {TclCopyFilesCmd: copy a link } {unixOnly notRoot dontCopyLinks} {
file mkdir tfad1
file link -symbolic tfalink tfad1
file copy tfalink tfalink2
set r1 [file type tfalink]; # link
set r2 [file type tfalink2]; # directory
set r3 [file isdir tfad1]; # 1
set result [expr {("$r1" == "link") && ("$r2" == "directory") && $r3}]
file delete -force tfad1 tfalink tfalink2
set result
} {1}
test fCmd-21.8.2 {TclCopyFilesCmd: copy a link } {unixOnly notRoot} {
file mkdir tfad1
file link -symbolic tfalink tfad1
file copy tfalink tfalink2
set r1 [file type tfalink]; # link
set r2 [file type tfalink2]; # link
set r3 [file isdir tfad1]; # 1
set result [expr {("$r1" == "link") && ("$r2" == "link") && $r3}]
file delete -force tfad1 tfalink tfalink2
set result
} {1}
test fCmd-21.9 {TclCopyFilesCmd: copy dir with a link in it} {unixOnly notRoot} {
file mkdir tfad1
file link -symbolic tfad1/tfalink "[pwd]/tfad1"
file copy tfad1 tfad2
set result [string match [file type tfad2/tfalink] link]
file delete -force tfad1 tfad2
set result
} {1}
test fCmd-21.10 {TclFileCopyCmd: copy dir on top of another empty dir w/o -force} \
|
| ︙ | ︙ | |||
1937 1938 1939 1940 1941 1942 1943 |
catch {file delete -force -- tfa tfad}
file mkdir tfa [file join tfad tfa file]
set r1 [catch {file copy -force tfa tfad}]
set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
file delete -force tfa tfad
set result
} {1}
| | | 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 |
catch {file delete -force -- tfa tfad}
file mkdir tfa [file join tfad tfa file]
set r1 [catch {file copy -force tfa tfad}]
set result [expr $r1 && [file isdir tfa] && [file isdir [file join tfad tfa file]]]
file delete -force tfa tfad
set result
} {1}
#
# Coverage testing for TclpRenameFile
#
test fCmd-22.1 {TclpRenameFile: rename and overwrite in a single dir} {notRoot} {
catch {file delete -force -- tfa1 tfa2}
set s [createfile tfa1]
set s2 [createfile tfa2 q]
|
| ︙ | ︙ | |||
1962 1963 1964 1965 1966 1967 1968 |
set s [createfile tfa1]
file rename -force tfa1 tfa1
set result [checkcontent tfa1 $s]
file delete tfa1
set result
} {1}
| | | 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 |
set s [createfile tfa1]
file rename -force tfa1 tfa1
set result [checkcontent tfa1 $s]
file delete tfa1
set result
} {1}
test fCmd-22.3 {TclpRenameFile: rename dir to existing dir} {notRoot} {
catch {file delete -force -- d1 tfad}
file mkdir d1 [file join tfad d1]
set r1 [catch {file rename d1 tfad}]
set result [expr $r1 && [file isdir d1] && [file isdir [file join tfad d1]]]
file delete -force d1 tfad
set result
} {1}
|
| ︙ | ︙ | |||
2032 2033 2034 2035 2036 2037 2038 |
file exists tfa1
} {0}
#
# TclMacCopyDirectory
# Error cases are not covered.
#
| < | | < | < | | | | | | | 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 |
file exists tfa1
} {0}
#
# TclMacCopyDirectory
# Error cases are not covered.
#
test fCmd-25.1 {TclMacCopyDirectory: copying a normal directory} {notRoot notFileSharing} {
catch {file delete -force -- tfad1 tfad2}
file mkdir [file join tfad1 a b c]
file copy tfad1 tfad2
set result [expr [file isdir [file join tfad1 a b c]] && [file isdir [file join tfad2 a b c]]]
file delete -force tfad1 tfad2
set result
} {1}
test fCmd-25.2 {TclMacCopyDirectory: copying a short path normal directory} {notRoot notFileSharing} {
catch {file delete -force -- tfad1 tfad2}
file mkdir tfad1
file copy tfad1 tfad2
set result [expr [file isdir tfad1] && [file isdir tfad2]]
file delete tfad1 tfad2
set result
} {1}
test fCmd-25.3 {TclMacCopyDirectory: copying dirs between different dirs} {notRoot notFileSharing} {
catch {file delete -force -- tfad1 tfad2}
file mkdir [file join tfad1 x y z]
file mkdir [file join tfad2 dir]
file copy tfad1 [file join tfad2 dir]
set result [expr [file isdir [file join tfad1 x y z]] && [file isdir [file join tfad2 dir tfad1 x y z]]]
file delete -force tfad1 tfad2
set result
} {1}
#
# Functionality tests for TclDeleteFilesCmd
#
test fCmd-26.1 {TclDeleteFilesCmd: delete symlink} {unixOnly notRoot} {
catch {file delete -force -- tfad1 tfad2}
file mkdir tfad1
file link -symbolic tfalink tfad1
file delete tfalink
set r1 [file isdir tfad1]
set r2 [file exists tfalink]
set result [expr $r1 && !$r2]
file delete tfad1
set result
} {1}
test fCmd-26.2 {TclDeleteFilesCmd: delete dir with symlink} {unixOnly notRoot} {
catch {file delete -force -- tfad1 tfad2}
file mkdir tfad1
file mkdir tfad2
file link -symbolic [file join tfad2 link] tfad1
file delete -force tfad2
set r1 [file isdir tfad1]
set r2 [file exists tfad2]
set result [expr $r1 && !$r2]
file delete tfad1
set result
} {1}
test fCmd-26.3 {TclDeleteFilesCmd: delete dangling symlink} {unixOnly notRoot} {
catch {file delete -force -- tfad1 tfad2}
file mkdir tfad1
file link -symbolic tfad2 tfad1
file delete tfad1
file delete tfad2
set r1 [file exists tfad1]
set r2 [file exists tfad2]
set result [expr !$r1 && !$r2]
|
| ︙ | ︙ | |||
2136 2137 2138 2139 2140 2141 2142 |
set attrs [file attributes foo.tmp]
list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]
} {0 {}}
# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
if {$tcl_platform(platform) == "unix"} {
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < | 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 |
set attrs [file attributes foo.tmp]
list [catch {eval file attributes foo.tmp [lindex $attrs 0]}] [file delete -force -- foo.tmp]
} {0 {}}
# Find a group that exists on this Unix system, or else skip tests that
# require Unix groups.
if {$tcl_platform(platform) == "unix"} {
::tcltest::testConstraint foundGroup 0
catch {
set groupList [exec groups]
set group [lindex $groupList 0]
::tcltest::testConstraint foundGroup 1
}
} else {
::tcltest::testConstraint foundGroup 1
}
test fCmd-27.5 {TclFileAttrsCmd - setting one option} {foundGroup} {
catch {file delete -force -- foo.tmp}
createfile foo.tmp
set attrs [file attributes foo.tmp]
list [catch {eval file attributes foo.tmp [lrange $attrs 0 1]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
test fCmd-27.6 {TclFileAttrsCmd - setting more than one option} {foundGroup} {
catch {file delete -force -- foo.tmp}
createfile foo.tmp
set attrs [file attributes foo.tmp]
list [catch {eval file attributes foo.tmp [lrange $attrs 0 3]} msg] $msg [file delete -force -- foo.tmp]
} {0 {} {}}
if {[string equal $tcl_platform(platform) "windows"]} {
if {[string index $tcl_platform(osVersion) 0] >= 5 \
&& ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
tcltest::testConstraint linkDirectory 1
tcltest::testConstraint linkFile 1
} else {
tcltest::testConstraint linkDirectory 0
tcltest::testConstraint linkFile 0
}
} else {
tcltest::testConstraint linkFile 1
tcltest::testConstraint linkDirectory 1
}
test fCmd-28.1 {file link} {
list [catch {file link} msg] $msg
} {1 {wrong # args: should be "file link ?-linktype? linkname ?target?"}}
test fCmd-28.2 {file link} {
list [catch {file link a b c d} msg] $msg
} {1 {wrong # args: should be "file link ?-linktype? linkname ?target?"}}
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]
test fCmd-28.5 {file link: source already exists} {linkDirectory} {
cd [temporaryDirectory]
set res [list [catch {file link abc.dir abc2.dir} msg] $msg]
cd [workingDirectory]
set res
} {1 {could not create new link "abc.dir": that path already exists}}
test fCmd-28.6 {file link: unsupported operation} {linkDirectory macOrWin} {
cd [temporaryDirectory]
set res [list [catch {file link -hard abc.link abc.dir} msg] $msg]
cd [workingDirectory]
set res
} {1 {could not create new link "abc.link" pointing to "abc.dir": illegal operation on a directory}}
test fCmd-28.7 {file link: source already exists} {linkFile} {
cd [temporaryDirectory]
set res [list [catch {file link abc.file abc2.file} msg] $msg]
cd [workingDirectory]
set res
} {1 {could not create new link "abc.file": that path already exists}}
test fCmd-28.8 {file link} {linkFile winOnly} {
cd [temporaryDirectory]
set res [list [catch {file link -symbolic abc.link abc.file} msg] $msg]
cd [workingDirectory]
set res
} {1 {could not create new link "abc.link" pointing to "abc.file": not a directory}}
test fCmd-28.9 {file link: success with file} {linkFile} {
cd [temporaryDirectory]
file delete -force abc.link
set res [list [catch {file link abc.link abc.file} msg] $msg]
cd [workingDirectory]
set res
} {0 abc.file}
cd [temporaryDirectory]
catch {file delete -force abc.link}
cd [workingDirectory]
test fCmd-28.10 {file link: linking to nonexistent path} {linkDirectory} {
cd [temporaryDirectory]
file delete -force abc.link
set res [list [catch {file link abc.link abc2.doesnt} msg] $msg]
cd [workingDirectory]
set res
} {1 {could not create new link "abc.link" since target "abc2.doesnt" doesn't exist}}
test fCmd-28.11 {file link: success with directory} {linkDirectory} {
cd [temporaryDirectory]
file delete -force abc.link
set res [list [catch {file link abc.link abc.dir} msg] $msg]
cd [workingDirectory]
set res
} {0 abc.dir}
test fCmd-28.12 {file link: cd into a link} {linkDirectory} {
cd [temporaryDirectory]
file delete -force abc.link
file link abc.link abc.dir
set orig [pwd]
cd abc.link
set dir [pwd]
cd ..
set up [pwd]
cd $orig
# now '$up' should be either $orig or [file dirname abc.dir],
# depending on whether 'cd' actually moves to the destination
# of a link, or simply treats the link as a directory.
# (on windows the former, on unix the latter, I believe)
if {([file normalize $up] != [file normalize $orig]) \
&& ([file normalize $up] != [file normalize [file dirname abc.dir]])} {
set res "wrong directory with 'cd $link ; cd ..'"
} else {
set res "ok"
}
cd [workingDirectory]
set res
} {ok}
test fCmd-28.13 {file link} {linkDirectory} {
# duplicate link throws error
cd [temporaryDirectory]
set res [list [catch {file link abc.link abc.dir} msg] $msg]
cd [workingDirectory]
set res
} {1 {could not create new link "abc.link": that path already exists}}
test fCmd-28.14 {file link: deletes link not dir} {linkDirectory} {
cd [temporaryDirectory]
file delete -force abc.link
set res [list [file exists abc.link] [file exists abc.dir]]
cd [workingDirectory]
set res
} {0 1}
test fCmd-28.15.1 {file link: copies link not dir} {linkDirectory dontCopyLinks} {
cd [temporaryDirectory]
file delete -force abc.link
file link abc.link abc.dir
file copy abc.link abc2.link
# abc2.linkdir was a copy of a link to a dir, so it should end up as
# a directory, not a link (links trace to endpoint).
set res [list [file type abc2.link] [file tail [file link abc.link]]]
cd [workingDirectory]
set res
} {directory abc.dir}
test fCmd-28.15.2 {file link: copies link not dir} {linkDirectory} {
cd [temporaryDirectory]
file delete -force abc.link
file link abc.link abc.dir
file copy abc.link abc2.link
set res [list [file type abc2.link] [file tail [file link abc2.link]]]
cd [workingDirectory]
set res
} {link abc.dir}
cd [temporaryDirectory]
file delete -force abc.link
file delete -force abc2.link
file copy abc.file abc.dir
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 [glob -dir abc.link -tails *]
cd [workingDirectory]
set res
} {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}
test fCmd-28.18 {file link: glob -type d} {linkDirectory} {
cd [temporaryDirectory]
set res [lsort [glob -dir [pwd] -type d -tails abc*]]
cd [workingDirectory]
set res
} [lsort [list abc.link abc.dir abc2.dir]]
test fCmd-29.1 {weird memory corruption fault} {
catch {set res [open [file join ~a_totally_bogus_user_id/foo bar]]}
} 1
cd [temporaryDirectory]
file delete -force abc.link
cd [workingDirectory]
removeFile abc2.file
removeFile abc.file
removeDirectory abc2.dir
removeDirectory abc.dir
# cleanup
cleanup
::tcltest::cleanupTests
return
|
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.14.8.3 2002/08/20 20:25:27 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
tcltest::testConstraint testsetplatform [string equal testsetplatform [info commands testsetplatform]]
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
if {[tcltest::testConstraint testsetplatform]} {
testsetplatform $platform
}
test filename-4.19 {Tcl_SplitPath} {
set oldDir [pwd]
set res [catch {
file mkdir tildetmp
set nastydir [file join tildetmp ./~tilde]
file mkdir $nastydir
set norm [file normalize $nastydir]
cd tildetmp
cd ./~tilde
glob -nocomplain *
| > | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
if {[tcltest::testConstraint testsetplatform]} {
testsetplatform $platform
}
test filename-4.19 {Tcl_SplitPath} {
set oldDir [pwd]
set res [catch {
cd [temporaryDirectory]
file mkdir tildetmp
set nastydir [file join tildetmp ./~tilde]
file mkdir $nastydir
set norm [file normalize $nastydir]
cd tildetmp
cd ./~tilde
glob -nocomplain *
|
| ︙ | ︙ | |||
1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 |
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} {
list [catch {file join [lindex [glob ~] 0]} msg] $msg
} [list 0 [file join $env(HOME)]]
set oldhome $env(HOME)
set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
file mkdir globTest/a1/b2
file mkdir globTest/a2/b3
file mkdir globTest/a3
close [open globTest/x1.c w]
| > > | 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 |
testsetplatform $platform
}
test filename-11.13 {Tcl_GlobCmd} {
list [catch {file join [lindex [glob ~] 0]} msg] $msg
} [list 0 [file join $env(HOME)]]
set oldpwd [pwd]
set oldhome $env(HOME)
cd [temporaryDirectory]
set env(HOME) [pwd]
file delete -force globTest
file mkdir globTest/a1/b1
file mkdir globTest/a1/b2
file mkdir globTest/a2/b3
file mkdir globTest/a3
close [open globTest/x1.c w]
|
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 |
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
| > > > > > > > > > > | | | | | | | 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 |
} [list 0 [lsort [list [file join $globname a1] [file join $globname a2]\
[file join $globname .1]\
[file join $globname a3]\
[file join $globname "weird name.c"]\
[file join $globname x,z1.c]\
[file join $globname x1.c]\
[file join $globname y1.c] [file join $globname z1.c]]]]
if {[string equal $tcl_platform(platform) "windows"]} {
if {[string index $tcl_platform(osVersion) 0] >= 5 \
&& ([lindex [file system [temporaryDirectory]] 1] == "NTFS")} {
tcltest::testConstraint linkDirectory 1
} else {
tcltest::testConstraint linkDirectory 0
}
} else {
tcltest::testConstraint linkDirectory 1
}
test filename-11.17.2 {Tcl_GlobCmd} {notRoot linkDirectory} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
file link -symbolic link a1
cd $dir
set ret [list [catch {
lsort [glob -directory $globname -join * b1]
} msg] $msg]
}]} {
cd $dir
}
file delete [file join $globname link]
set ret
} [list 0 [lsort [list [file join $globname a1 b1] \
[file join $globname link b1]]]]
# Simpler version of the above test to illustrate a given bug.
test filename-11.17.3 {Tcl_GlobCmd} {notRoot linkDirectory} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
file link -symbolic link a1
cd $dir
set ret [list [catch {
lsort [glob -directory $globname -type d *]
} msg] $msg]
}]} {
cd $dir
}
file delete [file join $globname link]
set ret
} [list 0 [lsort [list [file join $globname a1] \
[file join $globname a2] \
[file join $globname a3] \
[file join $globname link]]]]
# Make sure the bugfix isn't too simple. We don't want
# to break 'glob -type l'.
test filename-11.17.4 {Tcl_GlobCmd} {notRoot linkDirectory} {
set dir [pwd]
set ret "error in test"
if {[catch {
cd $globname
file link -symbolic link a1
cd $dir
set ret [list [catch {
lsort [glob -directory $globname -type l *]
} msg] $msg]
}]} {
cd $dir
}
|
| ︙ | ︙ | |||
1483 1484 1485 1486 1487 1488 1489 |
list [catch {glob -types hidden {}} msg] $msg
} {1 {no files matched glob pattern ""}}
test filename-12.3 {simple globbing} {
list [catch {glob -nocomplain \{a1,a2\}} msg] $msg
} {0 {}}
if {$tcl_platform(platform) == "macintosh"} {
| | | | 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 |
list [catch {glob -types hidden {}} msg] $msg
} {1 {no files matched glob pattern ""}}
test filename-12.3 {simple globbing} {
list [catch {glob -nocomplain \{a1,a2\}} msg] $msg
} {0 {}}
if {$tcl_platform(platform) == "macintosh"} {
set globPreResult :globTest:
} else {
set globPreResult globTest/
}
set x1 x1.c
set y1 y1.c
test filename-12.4 {simple globbing} {unixOrPc} {
lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
} "$globPreResult$x1 $globPreResult$y1"
test filename-12.5 {simple globbing} {
|
| ︙ | ︙ | |||
1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 |
} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.6 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob */*/*/*.c]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
test filename-14.7 {asterisks, question marks, and brackets} {unixOnly} {
lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.7.1 {asterisks, question marks, and brackets} {pcOnly} {
lsort [glob globTest/*]
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.8 {asterisks, question marks, and brackets} {macOnly} {
| > > > > > > > > > > > > > | 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 |
} {{:globTest:weird name.c} :globTest:x,z1.c :globTest:x1.c :globTest:y1.c :globTest:z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.4 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob globTest/?1.c]
} {:globTest:x1.c :globTest:y1.c :globTest:z1.c}
# The current directory could be anywhere; do this to stop spurious matches
file mkdir globTestContext
file rename globTest [file join globTestContext globTest]
set savepwd [pwd]
cd globTestContext
test filename-14.5 {asterisks, question marks, and brackets} {unixOrPc} {
lsort [glob */*/*/*.c]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-14.6 {asterisks, question marks, and brackets} {macOnly} {
lsort [glob */*/*/*.c]
} {:globTest:a1:b1:x2.c :globTest:a1:b2:y2.c}
# Reset to where we were
cd $savepwd
file rename [file join globTestContext globTest] globTest
file delete globTestContext
test filename-14.7 {asterisks, question marks, and brackets} {unixOnly} {
lsort [glob globTest/*]
} {globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.7.1 {asterisks, question marks, and brackets} {pcOnly} {
lsort [glob globTest/*]
} {globTest/.1 globTest/a1 globTest/a2 globTest/a3 {globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.8 {asterisks, question marks, and brackets} {macOnly} {
|
| ︙ | ︙ | |||
1671 1672 1673 1674 1675 1676 1677 | unset globname # The following tests are only valid for Unix systems. # On some systems, like AFS, "000" protection doesn't prevent # access by owner, so the following test is not portable. | | | | 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 |
unset globname
# The following tests are only valid for Unix systems.
# On some systems, like AFS, "000" protection doesn't prevent
# access by owner, so the following test is not portable.
catch {file attributes globTest/a1 -permissions 0000}
test filename-15.1 {unix specific globbing} {unixOnly nonPortable} {
string tolower [list [catch {glob globTest/a1/*} msg] $msg $errorCode]
} {1 {couldn't read directory "globtest/a1": permission denied} {posix eacces {permission denied}}}
test filename-15.2 {unix specific no complain: no errors} {unixOnly nonPortable} {
glob -nocomplain globTest/a1/*
} {}
test filename-15.3 {unix specific no complain: no errors, good result} \
{unixOnly nonPortable} {
# test fails because if an error occur , the interp's result
# is reset...
glob -nocomplain globTest/a2 globTest/a1/* globTest/a3
} {globTest/a2 globTest/a3}
catch {file attributes globTest/a1 -permissions 0755}
test filename-15.4 {unix specific no complain: no errors, good result} \
{unixOnly nonPortable} {
# test fails because if an error occurs, the interp's result
# is reset... or you don't run at scriptics where the
# outser and welch users exists
glob -nocomplain ~ouster ~foo ~welch
} {/home/ouster /home/welch}
|
| ︙ | ︙ | |||
1711 1712 1713 1714 1715 1716 1717 |
global env
set temp $env(HOME)
set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
set result [list [catch {glob ~} msg] $msg]
set env(HOME) $temp
set result
} [list 0 [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name]]
| | | 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 |
global env
set temp $env(HOME)
set env(HOME) $env(HOME)/globTest/odd\\\[\]*?\{\}name
set result [list [catch {glob ~} msg] $msg]
set env(HOME) $temp
set result
} [list 0 [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name]]
catch {file delete -force globTest/odd\\\[\]*?\{\}name}
# The following tests are only valid for Windows systems.
set oldDir [pwd]
if {$::tcltest::testConstraints(pcOnly)} {
cd c:/
file delete -force globTest
file mkdir globTest
|
| ︙ | ︙ | |||
1788 1789 1790 1791 1792 1793 1794 |
} {..}
test filename-16.16 {windows specific globbing} {pcOnly} {
file tail [lindex [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] 0]
} {..}
# cleanup
catch {file delete -force C:/globTest}
| < > | 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 |
} {..}
test filename-16.16 {windows specific globbing} {pcOnly} {
file tail [lindex [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] 0]
} {..}
# cleanup
catch {file delete -force C:/globTest}
file delete -force globTest
cd $oldpwd
set env(HOME) $oldhome
if {[tcltest::testConstraint testsetplatform]} {
testsetplatform $platform
catch {unset platform}
}
catch {unset oldhome temp result}
::tcltest::cleanupTests
return
|
Changes to tests/fileSystem.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.
package require tcltest
namespace eval ::tcl::test::fileSystem {
| > | | | | | | > > > > > > > | | | | | > > > > > | > | | | | > | | > | | > | | > > > > > > > > > > > > > > > > > > > > > > > | > | > | > | > > | > | > > > > > > > > | > > > > > > > > | > > | 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 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
package require tcltest
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]
}
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
}
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}
test filesystem-1.2 {link normalisation} {hasLinks macOrUnix} {
string equal [file normalize [file join gorp.file foo]] \
[file normalize [file join link.file foo]]
} {1}
test filesystem-1.3 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file foo]] \
[file normalize [file join dir.link foo]]
} {1}
test filesystem-1.4 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file inside.file]] \
[file normalize [file join dir.link inside.file]]
} {1}
test filesystem-1.5 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file linkinside.file]] \
[file normalize [file join dir.file linkinside.file]]
} {1}
test filesystem-1.6 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file linkinside.file]] \
[file normalize [file join dir.link inside.file]]
} {0}
test filesystem-1.7 {link normalisation} {hasLinks macOrUnix} {
string equal [file normalize [file join dir.link linkinside.file foo]] \
[file normalize [file join dir.file inside.file foo]]
} {1}
test filesystem-1.8 {link normalisation} {hasLinks} {
string equal [file normalize [file join dir.file linkinside.filefoo]] \
[file normalize [file join dir.link inside.filefoo]]
} {0}
test filesystem-1.9 {link normalisation} {macOrUnix hasLinks} {
file delete -force dir.link
file link dir.link [file nativename dir.file]
string equal [file normalize [file join dir.file linkinside.file foo]] \
[file normalize [file join dir.link inside.file foo]]
} {1}
test filesystem-1.10 {link normalisation: double link} {macOrUnix hasLinks} {
file link dir2.link dir.link
string equal [file normalize [file join dir.file linkinside.file foo]] \
[file normalize [file join dir2.link inside.file foo]]
} {1}
makeDirectory dir2.file
test filesystem-1.11 {link normalisation: double link, back in tree} {macOrUnix hasLinks} {
file link [file join dir2.file dir2.link] dir2.link
string equal [file normalize [file join dir.file linkinside.file foo]] \
[file normalize [file join dir2.file dir2.link inside.file foo]]
} {1}
test filesystem-1.12 {file new native path} {} {
for {set i 0} {$i < 10} {incr i} {
foreach f [lsort [glob -nocomplain -type l *]] {
catch {file readlink $f}
}
}
# If we reach here we've succeeded. We used to crash above.
expr 1
} {1}
test filesystem-1.13 {file normalisation} {winOnly} {
# This used to be broken
file normalize C:/thislongnamedoesntexist
} {C:/thislongnamedoesntexist}
test filesystem-1.14 {file normalisation} {winOnly} {
# This used to be broken
file normalize c:/
} {C:/}
file delete -force dir2.file
file delete -force dir2.link
file delete -force link.file dir.link
removeFile [file join dir.file inside.file]
removeDirectory dir.file
removeFile gorp.file
test filesystem-2.0 {new native path} {unixOnly} {
foreach f [lsort [glob -nocomplain /usr/bin/c*]] {
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
set ::env(HOME) /a/b/c
set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
set ::env(HOME) $orig
list $res1 $res2
}
-result {{Parent of ~ \(/foo/bar/blah\) is (/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is (/a/b|a:b)}}
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
set ::env(HOME) /a/b/c
set res2 "Parent of ~ (/a/b/c) is [file dirname $testdir]"
set ::env(HOME) $orig
list $res1 $res2
}
-result {{Parent of ~ \(/foo/bar/blah\) is (/foo/bar|foo:bar)} {Parent of ~ \(/a/b/c\) is (/a/b|a:b)}}
}
test filesystem-6.1 {empty file name} {
list [catch {open ""} msg] $msg
} {1 {couldn't open "": no such file or directory}}
test filesystem-6.2 {empty file name} {
list [catch {file stat "" arr} msg] $msg
} {1 {could not read "": no such file or directory}}
test filesystem-6.3 {empty file name} {
list [catch {file atime ""} msg] $msg
} {1 {could not read "": no such file or directory}}
test filesystem-6.4 {empty file name} {
list [catch {file attributes ""} msg] $msg
} {1 {could not read "": no such file or directory}}
test filesystem-6.5 {empty file name} {
list [catch {file copy "" ""} msg] $msg
} {1 {error copying "": no such file or directory}}
test filesystem-6.6 {empty file name} {
list [catch {file delete ""} msg] $msg
} {0 {}}
test filesystem-6.7 {empty file name} {
list [catch {file dirname ""} msg] $msg
} {0 .}
test filesystem-6.8 {empty file name} {
list [catch {file executable ""} msg] $msg
} {0 0}
test filesystem-6.9 {empty file name} {
list [catch {file exists ""} msg] $msg
} {0 0}
test filesystem-6.10 {empty file name} {
list [catch {file extension ""} msg] $msg
} {0 {}}
test filesystem-6.11 {empty file name} {
list [catch {file isdirectory ""} msg] $msg
} {0 0}
test filesystem-6.12 {empty file name} {
list [catch {file isfile ""} msg] $msg
} {0 0}
test filesystem-6.13 {empty file name} {
list [catch {file join ""} msg] $msg
} {0 {}}
test filesystem-6.14 {empty file name} {
list [catch {file link ""} msg] $msg
} {1 {could not read link "": no such file or directory}}
test filesystem-6.15 {empty file name} {
list [catch {file lstat "" arr} msg] $msg
} {1 {could not read "": no such file or directory}}
test filesystem-6.16 {empty file name} {
list [catch {file mtime ""} msg] $msg
} {1 {could not read "": no such file or directory}}
test filesystem-6.17 {empty file name} {
list [catch {file mtime "" 0} msg] $msg
} {1 {could not read "": no such file or directory}}
test filesystem-6.18 {empty file name} {
list [catch {file mkdir ""} msg] $msg
} {1 {can't create directory "": no such file or directory}}
test filesystem-6.19 {empty file name} {
list [catch {file nativename ""} msg] $msg
} {0 {}}
test filesystem-6.20 {empty file name} {
list [catch {file normalize ""} msg] $msg
} {0 {}}
test filesystem-6.21 {empty file name} {
list [catch {file owned ""} msg] $msg
} {0 0}
test filesystem-6.22 {empty file name} {
list [catch {file pathtype ""} msg] $msg
} {0 relative}
test filesystem-6.23 {empty file name} {
list [catch {file readable ""} msg] $msg
} {0 0}
test filesystem-6.24 {empty file name} {
list [catch {file readlink ""} msg] $msg
} {1 {could not readlink "": no such file or directory}}
test filesystem-6.25 {empty file name} {
list [catch {file rename "" ""} msg] $msg
} {1 {error renaming "": no such file or directory}}
test filesystem-6.26 {empty file name} {
list [catch {file rootname ""} msg] $msg
} {0 {}}
test filesystem-6.27 {empty file name} {
list [catch {file separator ""} msg] $msg
} {1 {Unrecognised path}}
test filesystem-6.28 {empty file name} {
list [catch {file size ""} msg] $msg
} {1 {could not read "": no such file or directory}}
test filesystem-6.29 {empty file name} {
list [catch {file split ""} msg] $msg
} {0 {}}
test filesystem-6.30 {empty file name} {
list [catch {file system ""} msg] $msg
} {1 {Unrecognised path}}
test filesystem-6.31 {empty file name} {
list [catch {file tail ""} msg] $msg
} {0 {}}
test filesystem-6.32 {empty file name} {
list [catch {file type ""} msg] $msg
} {1 {could not read "": no such file or directory}}
test filesystem-6.33 {empty file name} {
list [catch {file writable ""} msg] $msg
} {0 0}
# Make sure the testfilesystem hasn't been registered.
while {![catch {testfilesystem 0}]} {}
}
cleanupTests
}
namespace delete ::tcl::test::fileSystem
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 21 22 23 |
# 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.9.8.2 2002/08/20 20:25:27 das 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
# a round-off error in sprintf which would cause some of the tests to
# fail. Someday I hope this code shouldn't be necessary (code added
# 9/9/91).
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 |
for {set i 290} {$i < 400} {incr i} {
test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
format {%s} $b
} $b
append b "x"
}
| | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 |
for {set i 290} {$i < 400} {incr i} {
test format-16.[expr $i -289] {testing MAX_FLOAT_SIZE} {
format {%s} $b
} $b
append b "x"
}
::tcltest::testConstraint 64bitInts \
[expr {0x80000000 > 0}]
::tcltest::testConstraint wideIntExpressions \
[expr {wide(0x80000000) != int(0x80000000)}]
test format-17.1 {testing %d with wide} {64bitInts wideIntExpressions} {
list [catch {format %d 7810179016327718216} msg] $msg
} {1 {integer value too large to represent}}
test format-17.2 {testing %ld with wide} {64bitInts} {
format %ld 7810179016327718216
|
| ︙ | ︙ |
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 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 |
# 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.25.2.1 2002/08/20 20:25:27 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
if {[catch {package require http 2} version]} {
if {[info exist http2]} {
catch {puts "Cannot load http 2.* package"}
return
} else {
catch {puts "Running http 2.* tests in slave interp"}
set interp [interp create http2]
$interp eval [list set http2 "running"]
$interp eval [list set argv $argv]
$interp eval [list source [info script]]
interp delete $interp
return
}
}
proc bgerror {args} {
global errorInfo
puts stderr "http.test bgerror"
puts stderr [join $args]
puts stderr $errorInfo
}
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 $::tcltest::testsDirectory httpd]
set httpdFile [file join [temporaryDirectory] httpd_[pid]]
if {![file exists $httpdFile]} {
makeFile "" $httpdFile
file delete $httpdFile
file copy $origFile $httpdFile
set removeHttpd 1
}
if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
set httpthread [testthread create "
source [list $httpdFile]
testthread wait
"]
testthread send $httpthread [list set port $port]
testthread send $httpthread [list set bindata $bindata]
testthread send $httpthread {httpd_init $port}
puts "Running httpd in thread $httpthread"
} else {
if {![file exists $httpdFile]} {
puts "Cannot read $httpdFile script, http test skipped"
unset port
return
}
source $httpdFile
# Let the OS pick the port; that's much more flexible
if {[catch {httpd_init 0} listen]} {
puts "Cannot start http server, http test skipped"
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 {} -useragent "Tcl http client package $version"]
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
set i 0
# Create about 120K of query data
while {$i < 14} {
incr i
append query $sep$query
set sep &
}
| | | | > | | | 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 |
set i 0
# Create about 120K of query data
while {$i < 14} {
incr i
append query $sep$query
set sep &
}
set file [makeFile $query outdata]
set fp [open $file]
proc asyncCB {token} {
global postResult
lappend postResult [http::data $token]
}
set postResult [list ]
set t [http::geturl $posturl -querychannel $fp]
http::wait $t
set testRes [list [http::status $t] [string length $query] [http::data $t]]
# Now do async
http::cleanup $t
close $fp
set fp [open $file]
set t [http::geturl $posturl -querychannel $fp -command asyncCB]
set postResult [list PostStart]
http::wait $t
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
append query $sep$query
set sep &
}
set file [makeFile $query outdata]
set fp [open $file]
proc asyncCB {token} {
global postResult
lappend postResult [http::data $token]
}
proc postProgress {token x y} {
global postProgress
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
http::wait $t
upvar #0 $t state
} err]} {
puts $errorInfo
error $err
}
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}
| > | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
http::wait $t
upvar #0 $t state
} err]} {
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}
|
| ︙ | ︙ | |||
316 317 318 319 320 321 322 |
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} {
| > | | | > | | > | | | | 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 |
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$binurl"
proc myProgress {token total current} {
global progress httpLog
if {[info exists httpLog] && $httpLog} {
puts "progress $total $current"
|
| ︙ | ︙ | |||
482 483 484 485 486 487 488 |
} else {
close $listen
}
if {[info exist removeHttpd]} {
removeFile $httpdFile
}
| < < | < | 492 493 494 495 496 497 498 499 500 |
} else {
close $listen
}
if {[info exist removeHttpd]} {
removeFile $httpdFile
}
::tcltest::cleanupTests
|
Changes to tests/httpold.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: http_config, http_get, http_wait, http_reset # # This file contains a collection of tests for the http script library. # 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 25 26 27 28 29 30 31 32 33 34 35 36 37 |
# Commands covered: http_config, http_get, http_wait, http_reset
#
# This file contains a collection of tests for the http script library.
# 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: httpold.test,v 1.8.18.1 2002/08/20 20:25:27 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {[catch {package require http 1.0}]} {
if {[info exist httpold]} {
catch {puts "Cannot load http 1.0 package"}
::tcltest::cleanupTests
return
} else {
catch {puts "Running http 1.0 tests in slave interp"}
set interp [interp create httpold]
$interp eval [list set httpold "running"]
$interp eval [list set argv $argv]
$interp eval [list source [info script]]
interp delete $interp
::tcltest::cleanupTests
return
}
}
|
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
if [catch {httpd_init $port} listen] {
puts "Cannot start http server, http test skipped"
unset port
::tcltest::cleanupTests
return
}
| | | | | | | | | | | | | | | | | | | | > | | | | > | | | > | | | | | | | | | | | | | | | 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 |
if [catch {httpd_init $port} listen] {
puts "Cannot start http server, http test skipped"
unset port
::tcltest::cleanupTests
return
}
test httpold-1.1 {http_config} {
http_config
} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
test httpold-1.2 {http_config} {
http_config -proxyfilter
} httpProxyRequired
test httpold-1.3 {http_config} {
catch {http_config -junk}
} 1
test httpold-1.4 {http_config} {
http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
set x [http_config]
http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
-useragent "Tcl http client package 1.0"
set x
} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
test httpold-1.5 {http_config} {
catch {http_config -proxyhost {} -junk 8080}
} 1
test httpold-2.1 {http_reset} {
catch {http_reset http#1}
} 0
test httpold-3.1 {http_get} {
catch {http_get -bogus flag}
} 1
test httpold-3.2 {http_get} {
catch {http_get http:junk} err
set err
} {Unsupported URL: http:junk}
set url [info hostname]:$port
test httpold-3.3 {http_get} {
set token [http_get $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 binurl [info hostname]:$port/binary
test httpold-3.4 {http_get} {
set token [http_get $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 httpold-3.5 {http_get} {
http_config -proxyfilter selfproxy
set token [http_get $url]
http_config -proxyfilter httpProxyRequired
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 httpold-3.6 {http_get} {
http_config -proxyfilter bogus
set token [http_get $url]
http_config -proxyfilter httpProxyRequired
http_data $token
} "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
test httpold-3.7 {http_get} {
set token [http_get $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 httpold-3.8 {http_get} {
set token [http_get $url -query Name=Value&Foo=Bar]
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 httpold-3.9 {http_get} {
set token [http_get $url -validate 1]
http_code $token
} "HTTP/1.0 200 OK"
test httpold-4.1 {httpEvent} {
set token [http_get $url]
upvar #0 $token data
array set meta $data(meta)
expr ($data(totalsize) == $meta(Content-Length))
} 1
test httpold-4.2 {httpEvent} {
set token [http_get $url]
upvar #0 $token data
array set meta $data(meta)
string compare $data(type) [string trim $meta(Content-Type)]
} 0
test httpold-4.3 {httpEvent} {
set token [http_get $url]
http_code $token
} {HTTP/1.0 200 Data follows}
test httpold-4.4 {httpEvent} {
set testfile [makeFile "" testfile]
set out [open $testfile w]
set token [http_get $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 httpold-4.5 {httpEvent} {
set testfile [makeFile "" testfile]
set out [open $testfile w]
set token [http_get $url -channel $out]
close $out
upvar #0 $token data
removeFile $testfile
expr $data(currentsize) == $data(totalsize)
} 1
test httpold-4.6 {httpEvent} {
set testfile [makeFile "" testfile]
set out [open $testfile w]
set token [http_get $binurl -channel $out]
close $out
set in [open $testfile]
fconfigure $in -translation binary
set x [read $in]
close $in
removeFile $testfile
set x
} "$bindata$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 httpold-4.6 {httpEvent} {
set token [http_get $url -blocksize 50 -progress myProgress]
set progress
} {111 111}
}
test httpold-4.7 {httpEvent} {
set token [http_get $url -progress myProgress]
set progress
} {111 111}
test httpold-4.8 {httpEvent} {
set token [http_get $url]
http_status $token
} {ok}
test httpold-4.9 {httpEvent} {
set token [http_get $url -progress myProgress]
http_code $token
} {HTTP/1.0 200 Data follows}
test httpold-4.10 {httpEvent} {
set token [http_get $url -progress myProgress]
http_size $token
} {111}
test httpold-4.11 {httpEvent} {
set token [http_get $url -timeout 1 -command {#}]
http_reset $token
http_status $token
} {reset}
test httpold-4.12 {httpEvent} {
update
set x {}
after 500 {lappend x ok}
set token [http_get $url -timeout 1 -command {lappend x fail}]
vwait x
list [http_status $token] $x
} {timeout ok}
test httpold-5.1 {http_formatQuery} {
http_formatQuery name1 value1 name2 "value two"
} {name1=value1&name2=value+two}
test httpold-5.2 {http_formatQuery} {
http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
} {name1=%7ebwelch&name2=%a1%a2%a2}
test httpold-5.3 {http_formatQuery} {
http_formatQuery lines "line1\nline2\nline3"
} {lines=line1%0d%0aline2%0d%0aline3}
test httpold-6.1 {httpProxyRequired} {
update
http_config -proxyhost [info hostname] -proxyport $port
set token [http_get $url]
http_wait $token
http_config -proxyhost {} -proxyport {}
upvar #0 $token data
set data(body)
|
| ︙ | ︙ |
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 |
# 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.
#
# RCS: @(#) $Id: info.test,v 1.17.10.2 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Set up namespaces needed to test operation of "info args", "info body",
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 374 375 376 377 378 379 380 |
test info-12.1 {info locals option} {
set a 22
proc t1 {x y} {
set b 13
set c testing
global a
return [info locals]
}
lsort [t1 23 24]
} {b c x y}
test info-12.2 {info locals option} {
proc t1 {x y} {
set xx1 2
| > > | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
test info-12.1 {info locals option} {
set a 22
proc t1 {x y} {
set b 13
set c testing
global a
global aa
set aa 23
return [info locals]
}
lsort [t1 23 24]
} {b c x y}
test info-12.2 {info locals option} {
proc t1 {x y} {
set xx1 2
|
| ︙ | ︙ | |||
515 516 517 518 519 520 521 |
test info-16.1 {info script option} {
list [catch {info script x x} msg] $msg
} {1 {wrong # args: should be "info script ?filename?"}}
test info-16.2 {info script option} {
file tail [info sc]
} "info.test"
| < | | | | | | | | | | 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 |
test info-16.1 {info script option} {
list [catch {info script x x} msg] $msg
} {1 {wrong # args: should be "info script ?filename?"}}
test info-16.2 {info script option} {
file tail [info sc]
} "info.test"
set gorpfile [makeFile "info script\n" gorp.info]
test info-16.3 {info script option} {
list [source $gorpfile] [file tail [info script]]
} [list $gorpfile info.test]
test info-16.4 {resetting "info script" after errors} {
catch {source ~_nobody_/foo}
file tail [info script]
} "info.test"
test info-16.5 {resetting "info script" after errors} {
catch {source _nonexistent_}
file tail [info script]
} "info.test"
test info-16.6 {info script option} {
set script [info script]
list [file tail [info script]] \
[info script newname.txt] \
[file tail [info script $script]]
} [list info.test newname.txt info.test]
test info-16.7 {info script option} {
set script [info script]
info script newname.txt
list [source $gorpfile] [file tail [info script]] \
[file tail [info script $script]]
} [list $gorpfile newname.txt info.test]
removeFile gorp.info
set gorpfile [makeFile {list [info script] [info script foo.bar]} gorp.info]
test info-16.8 {info script option} {
list [source $gorpfile] [file tail [info script]]
} [list [list $gorpfile foo.bar] info.test]
removeFile gorp.info
test info-17.1 {info sharedlibextension option} {
list [catch {info sharedlibextension foo} msg] $msg
} {1 {wrong # args: should be "info sharedlibextension"}}
test info-18.1 {info tclversion option} {
|
| ︙ | ︙ |
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 |
# 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.12.14.3 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# The set of hidden commands is platform dependent:
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
a eval bar s1 s2 s3
} {seen in master: {a1 a2 a3 s1 s2 s3}}
test interp-8.3 {testing basic alias invocation} {
catch {interp create a}
list [catch {a alias} msg] $msg
} {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}}
| | > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
a eval bar s1 s2 s3
} {seen in master: {a1 a2 a3 s1 s2 s3}}
test interp-8.3 {testing basic alias invocation} {
catch {interp create a}
list [catch {a alias} msg] $msg
} {1 {wrong # args: should be "a alias aliasName ?targetName? ?args..?"}}
# Part 8: Testing aliases for non-existent or hidden targets
test interp-9.1 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-master
list [catch {a eval zop} msg] $msg
} {1 {invalid command name "nonexistent-command-in-master"}}
test interp-9.2 {testing aliases for non-existent targets} {
catch {interp create a}
a alias zop nonexistent-command-in-master
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"}}}
test interp-9.4 {testing aliases and namespace commands} {
proc p {} {return GLOBAL}
namespace eval tst {
proc p {} {return NAMESPACE}
}
interp alias {} a {} p
set res [a]
lappend res [namespace eval tst a]
rename p {}
rename a {}
namespace delete tst
set res
} {GLOBAL GLOBAL}
if {[info command nonexistent-command-in-master] != ""} {
rename nonexistent-command-in-master {}
}
# Part 9: Aliasing between interpreters
test interp-10.1 {testing aliasing between interpreters} {
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
catch {interp delete z}
interp create z
z eval close stdout
list [catch {z eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
| < | | | | > < | | | | > < | | | | | | | | | | | | | | > | 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 |
# part 15: testing file sharing
test interp-15.1 {testing file sharing} {
catch {interp delete z}
interp create z
z eval close stdout
list [catch {z eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
test interp-15.2 {testing file sharing} -body {
catch {interp delete z}
interp create z
set f [open [makeFile {} file-15.2] w]
interp share "" $f z
z eval puts $f hello
z eval close $f
close $f
} -cleanup {
removeFile file-15.2
} -result ""
test interp-15.3 {testing file sharing} {
catch {interp delete xsafe}
interp create xsafe -safe
list [catch {xsafe eval puts hello} msg] $msg
} {1 {can not find channel named "stdout"}}
test interp-15.4 {testing file sharing} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.4] w]
interp share "" $f xsafe
xsafe eval puts $f hello
xsafe eval close $f
close $f
} -cleanup {
removeFile file-15.4
} -result ""
test interp-15.5 {testing file sharing} {
catch {interp delete xsafe}
interp create xsafe -safe
interp share "" stdout xsafe
list [catch {xsafe eval gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test interp-15.6 {testing file sharing} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.6] w]
interp share "" $f xsafe
set x [list [catch [list xsafe eval gets $f] msg] $msg]
xsafe eval close $f
close $f
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f]]
} -cleanup {
removeFile file-15.6
} -result 0
test interp-15.7 {testing file transferring} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.7] w]
interp transfer "" $f xsafe
xsafe eval puts $f hello
xsafe eval close $f
} -cleanup {
removeFile file-15.7
} -result ""
test interp-15.8 {testing file transferring} -body {
catch {interp delete xsafe}
interp create xsafe -safe
set f [open [makeFile {} file-15.8] w]
interp transfer "" $f xsafe
xsafe eval close $f
set x [list [catch {close $f} msg] $msg]
string compare [string tolower $x] \
[list 1 [format "can not find channel named \"%s\"" $f]]
} -cleanup {
removeFile file-15.8
} -result 0
#
# Torture tests for interpreter deletion order
#
proc kill {} {interp delete xxx}
test interp-15.9 {testing deletion order} {
|
| ︙ | ︙ | |||
2429 2430 2431 2432 2433 2434 2435 |
interp recursionlimit {} 50
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
| | | | | 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 |
interp recursionlimit {} 50
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 48}
test interp-29.3.2 {recursion limit} {
set i [interp create]
interp recursionlimit $i 50
set r [interp eval $i {
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 48}
test interp-29.3.3 {recursion limit} {
set i [interp create]
$i recursionlimit 50
set r [interp eval $i {
proc p {} {incr ::i; p}
set i 0
list [catch p msg] $msg $i
}]
interp delete $i
set r
} {1 {too many nested evaluations (infinite loop?)} 48}
test interp-29.3.4 {recursion limit error reporting} {
interp create slave
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
eval { # 3
|
| ︙ | ︙ | |||
2538 2539 2540 2541 2542 2543 2544 |
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
| | | 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 |
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.8 {recursion limit error reporting} {
interp create slave
after 0 {interp recursionlimit slave 4}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
|
| ︙ | ︙ | |||
2560 2561 2562 2563 2564 2565 2566 |
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
| | | 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 |
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.9 {recursion limit error reporting} {
interp create slave
after 0 {interp recursionlimit slave 6}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
|
| ︙ | ︙ | |||
2604 2605 2606 2607 2608 2609 2610 |
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
| | | 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 |
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.11 {recursion limit error reporting} {
interp create slave
after 0 {slave recursionlimit 5}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
|
| ︙ | ︙ | |||
2626 2627 2628 2629 2630 2631 2632 |
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
| | | 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 |
}
}
} msg
}]
set r2 [slave eval { set msg }]
interp delete slave
list $r1 $r2
} {1 {too many nested evaluations (infinite loop?)}}
test interp-29.3.12 {recursion limit error reporting} {
interp create slave
after 0 {slave recursionlimit 6}
set r1 [slave eval {
catch { # nesting level 1
eval { # 2
|
| ︙ | ︙ | |||
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 |
rename mySet {}
rename myNewSet {}
set result
} ok
test interp-32.1 { parent's working directory should
be inherited by a child interp } {
set parent [pwd]
set i [interp create]
set child [$i eval pwd]
interp delete $i
file mkdir cwd_test
cd cwd_test
lappend parent [pwd]
set i [interp create]
lappend child [$i eval pwd]
cd ..
file delete cwd_test
interp delete $i
expr {[string equal $parent $child] ? 1 :
"\{$parent\} != \{$child\}"}
} 1
# cleanup
foreach i [interp slaves] {
interp delete $i
}
::tcltest::cleanupTests
return
| > > | 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 |
rename mySet {}
rename myNewSet {}
set result
} ok
test interp-32.1 { parent's working directory should
be inherited by a child interp } {
cd [temporaryDirectory]
set parent [pwd]
set i [interp create]
set child [$i eval pwd]
interp delete $i
file mkdir cwd_test
cd cwd_test
lappend parent [pwd]
set i [interp create]
lappend child [$i eval pwd]
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
|
Changes to tests/io.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # 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. # | | > > | | | > > > | | | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
# 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.21.4.3 2002/08/20 20:25:28 das 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]]
# You need a *very* special environment to do some tests. In
# particular, many file systems do not support large-files...
testConstraint largefileSupport 0
removeFile test1
removeFile pipe
# 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
\#123456789abcdef01
\#"
}
close $f
set path(cat) [makeFile {
set f stdin
if {$argv != ""} {
set f [open $argv]
}
fconfigure $f -encoding binary -translation lf -blocking 0 -eofchar \x1a
fconfigure stdout -encoding binary -translation lf -buffering none
fileevent $f readable "foo $f"
proc foo {f} {
set x [read $f]
catch {puts -nonewline $x}
if {[eof $f]} {
close $f
exit 0
}
}
vwait forever
} cat]
set thisScript [file join [pwd] [info script]]
proc contents {file} {
set f [open $file]
fconfigure $f -translation binary
set a [read $f]
close $f
return $a
}
test io-1.5 {Tcl_WriteChars: CheckChannelErrors} {emptyTest} {
# no test, need to cause an async error.
} {}
set path(test1) [makeFile {} test1]
test io-1.6 {Tcl_WriteChars: WriteBytes} {
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "a\u4e4d\0"
close $f
contents $path(test1)
} "a\x4d\x00"
test io-1.7 {Tcl_WriteChars: WriteChars} {
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
puts -nonewline $f "a\u4e4d\0"
close $f
contents $path(test1)
} "a\x93\xe1\x00"
set path(test2) [makeFile {} test2]
test io-1.8 {Tcl_WriteChars: WriteChars} {
# This test written for SF bug #506297.
#
# Executing this test without the fix for the referenced bug
# applied to tcl will cause tcl, more specifically WriteChars, to
# go into an infinite loop.
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"
close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-2.2 {WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n expansion. It gets stuck at beginning of this buffer.
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345\n12"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-2.3 {WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a \n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the \n.
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffering line -translation crlf
puts -nonewline $f "\n12"
set x [contents $path(test1)]
close $f
set x
} "\r\n12"
test io-2.4 {WriteBytes: reset sawLF after each buffer} {
set f [open $path(test1) w]
fconfigure $f -encoding binary -buffering line -translation lf \
-buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-3.1 {WriteChars: compatibility with WriteBytes} {
# loop until all bytes are written
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffersize 16 -translation crlf
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
contents $path(test1)
} "abcdefghijklmnopqrstuvwxyz\r\n"
test io-3.2 {WriteChars: compatibility with WriteBytes: savedLF > 0} {
# After flushing buffer, there was a \n left over from the last
# \n -> \r\n expansion. It gets stuck at beginning of this buffer.
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffersize 16 -translation crlf
puts -nonewline $f "123456789012345\n12"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "123456789012345\r" "123456789012345\r\n12"]
test io-3.3 {WriteChars: compatibility with WriteBytes: flush on line} {
# Tcl "line" buffering has weird behavior: if current buffer contains
# a \n, entire buffer gets flushed. Logical behavior would be to flush
# only up to the \n.
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation crlf
puts -nonewline $f "\n12"
set x [contents $path(test1)]
close $f
set x
} "\r\n12"
test io-3.4 {WriteChars: loop over stage buffer} {
# stage buffer maps to more than can be queued at once.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 16
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.5 {WriteChars: saved != 0} {
# Bytes produced by UtfToExternal from end of last channel buffer
# had to be moved to beginning of next channel buffer to preserve
# requested buffersize.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.6 {WriteChars: (stageRead + dstWrote == 0)} {
# One incomplete UTF-8 character at end of staging buffer. Backup
# in src to the beginning of that UTF-8 character and try again.
#
# Translate the first 16 bytes, produce 14 bytes of output, 2 left over
# (first two bytes of \uff21 in UTF-8). Given those two bytes try
# translating them again, find that no bytes are read produced, and break
# to outer loop where those two bytes will have the remaining 4 bytes
# (the last byte of \uff21 plus the all of \uff22) appended.
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis -buffersize 16
puts -nonewline $f "12345678901234\uff21\uff22"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "12345678901234\x82\x60" "12345678901234\x82\x60\x82\x61"]
test io-3.7 {WriteChars: (bufPtr->nextAdded > bufPtr->length)} {
# When translating UTF-8 to external, the produced bytes went past end
# of the channel buffer. This is done purpose -- we then truncate the
# bytes at the end of the partial character to preserve the requested
# blocksize on flush. The truncated bytes are moved to the beginning
# of the next channel buffer.
set f [open $path(test1) w]
fconfigure $f -encoding jis0208 -buffersize 17
puts -nonewline $f "\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "!)!)!)!)!)!)!)!)!" "!)!)!)!)!)!)!)!)!)!)!)!)!)!)!)"]
test io-3.8 {WriteChars: reset sawLF after each buffer} {
set f [open $path(test1) w]
fconfigure $f -encoding ascii -buffering line -translation lf \
-buffersize 16
puts -nonewline $f "abcdefg\nhijklmnopqrstuvwxyz"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcdefg\nhijklmno" "abcdefg\nhijklmnopqrstuvwxyz"]
test io-4.1 {TranslateOutputEOL: lf} {
# search for \n
set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf
puts $f "abcde"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcde\n" "abcde\n"]
test io-4.2 {TranslateOutputEOL: cr} {
# search for \n, replace with \r
set f [open $path(test1) w]
fconfigure $f -buffering line -translation cr
puts $f "abcde"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcde\r" "abcde\r"]
test io-4.3 {TranslateOutputEOL: crlf} {
# simple case: search for \n, replace with \r
set f [open $path(test1) w]
fconfigure $f -buffering line -translation crlf
puts $f "abcde"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "abcde\r\n" "abcde\r\n"]
test io-4.4 {TranslateOutputEOL: crlf} {
# keep storing more bytes in output buffer until output buffer is full.
# We have 13 bytes initially that would turn into 18 bytes. Fill
# dest buffer while (dstEnd < dstMax).
set f [open $path(test1) w]
fconfigure $f -translation crlf -buffersize 16
puts -nonewline $f "1234567\n\n\n\n\nA"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567\r\n\r\n\r\n\r\n\r" "1234567\r\n\r\n\r\n\r\n\r\nA"]
test io-4.5 {TranslateOutputEOL: crlf} {
# Check for overflow of the destination buffer
set f [open $path(test1) w]
fconfigure $f -translation crlf -buffersize 12
puts -nonewline $f "12345678901\n456789012345678901234"
close $f
set x [contents $path(test1)]
} "12345678901\r\n456789012345678901234"
test io-5.1 {CheckFlush: not full} {
set f [open $path(test1) w]
fconfigure $f
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.2 {CheckFlush: full} {
set f [open $path(test1) w]
fconfigure $f -buffersize 16
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890123456" "12345678901234567890"]
test io-5.3 {CheckFlush: not line} {
set f [open $path(test1) w]
fconfigure $f -buffering line
puts -nonewline $f "12345678901234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "" "12345678901234567890"]
test io-5.4 {CheckFlush: line} {
set f [open $path(test1) w]
fconfigure $f -buffering line -translation lf -encoding ascii
puts -nonewline $f "1234567890\n1234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890\n1234567890" "1234567890\n1234567890"]
test io-5.5 {CheckFlush: none} {
set f [open $path(test1) w]
fconfigure $f -buffering none
puts -nonewline $f "1234567890"
set x [list [contents $path(test1)]]
close $f
lappend x [contents $path(test1)]
} [list "1234567890" "1234567890"]
test io-6.1 {Tcl_GetsObj: working} {
set f [open $path(test1) w]
puts $f "foo\nboo"
close $f
set f [open $path(test1)]
set x [gets $f]
close $f
set x
} {foo}
test io-6.2 {Tcl_GetsObj: CheckChannelErrors() != 0} {
# no test, need to cause an async error.
} {}
test io-6.3 {Tcl_GetsObj: how many have we used?} {
# if (bufPtr != NULL) {oldRemoved = bufPtr->nextRemoved}
set f [open $path(test1) w]
fconfigure $f -translation crlf
puts $f "abc\ndefg"
close $f
set f [open $path(test1)]
set x [list [tell $f] [gets $f line] [tell $f] [gets $f line] $line]
close $f
set x
} {0 3 5 4 defg}
test io-6.4 {Tcl_GetsObj: encoding == NULL} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts $f "\x81\u1234\0"
close $f
set f [open $path(test1)]
fconfigure $f -translation binary
set x [list [gets $f line] $line]
close $f
set x
} [list 3 "\x81\x34\x00"]
test io-6.5 {Tcl_GetsObj: encoding != NULL} {
set f [open $path(test1) w]
fconfigure $f -translation binary
puts $f "\x88\xea\x92\x9a"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line]
close $f
set x
} [list 2 "\u4e00\u4e01"]
set a "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
append a $a
append a $a
test io-6.6 {Tcl_GetsObj: loop test} {
# if (dst >= dstEnd)
set f [open $path(test1) w]
puts $f $a
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} {
# if (FilterInputBytes(chanPtr, &gs) != 0)
set f [open "|[list [interpreter] cat]" w+]
puts -nonewline $f "hi\nwould"
flush $f
gets $f
fconfigure $f -blocking 0
set x [gets $f line]
close $f
set x
} {-1}
test io-6.8 {Tcl_GetsObj: remember if EOF is seen} {
set f [open $path(test1) w]
puts $f "abcdef\x1aghijk\nwombat"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar \x1a
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {6 abcdef -1 {}}
test io-6.9 {Tcl_GetsObj: remember if EOF is seen} {
set f [open $path(test1) w]
puts $f "abcdefghijk\nwom\u001abat"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar \x1a
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {11 abcdefghijk 3 wom}
# Comprehensive tests
test io-6.10 {Tcl_GetsObj: lf mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.11 {Tcl_GetsObj: lf mode: lone \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {0 {} -1 {}}
test io-6.12 {Tcl_GetsObj: lf mode: lone \r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\r" -1 ""]
test io-6.13 {Tcl_GetsObj: lf mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.14 {Tcl_GetsObj: lf mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.15 {Tcl_GetsObj: lf mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation lf
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 4 "abcd" 10 "efgh\rijkl\r" 4 "mnop" -1 ""]
test io-6.16 {Tcl_GetsObj: cr mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.17 {Tcl_GetsObj: cr mode: lone \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\n" -1 ""]
test io-6.18 {Tcl_GetsObj: cr mode: lone \r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {0 {} -1 {}}
test io-6.19 {Tcl_GetsObj: cr mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.20 {Tcl_GetsObj: cr mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.21 {Tcl_GetsObj: cr mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 9 "abcd\nefgh" 4 "ijkl" 5 "\nmnop" -1 ""]
test io-6.22 {Tcl_GetsObj: crlf mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.23 {Tcl_GetsObj: crlf mode: lone \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\n" -1 ""]
test io-6.24 {Tcl_GetsObj: crlf mode: lone \r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 1 "\r" -1 ""]
test io-6.25 {Tcl_GetsObj: crlf mode: \r\r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 2 "\r\r" -1 ""]
test io-6.26 {Tcl_GetsObj: crlf mode: \r\n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.27 {Tcl_GetsObj: crlf mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.28 {Tcl_GetsObj: crlf mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.29 {Tcl_GetsObj: crlf mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 14 "abcd\nefgh\rijkl" 4 "mnop" -1 ""]
test io-6.30 {Tcl_GetsObj: crlf mode: buffer exhausted} {testchannel} {
# if (eol >= dstEnd)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r\nabcdefghijklmnoprstuvwxyz"
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} {
# (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]
fconfigure $f -blocking 0
lappend x [gets $f line] $line [fblocked $f] [testchannel inputbuffered $f]
close $f
set x
} [list "bbbbbbbbbbbbbb" -1 "" 1 16]
test io-6.32 {Tcl_GetsObj: crlf mode: buffer exhausted, more data} {testchannel} {
# not (FilterInputBytes() != 0)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r\n123"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [tell $f] [testchannel inputbuffered $f]]
close $f
set x
} [list 15 "123456789012345" 17 3]
test io-6.33 {Tcl_GetsObj: crlf mode: buffer exhausted, at eof} {
# eol still equals dstEnd
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 16 "123456789012345\r" 1]
test io-6.34 {Tcl_GetsObj: crlf mode: buffer exhausted, not followed by \n} {
# not (*eol == '\n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\rabcd\r\nefg"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf -buffersize 16
set x [list [gets $f line] $line [tell $f]]
close $f
set x
} [list 20 "123456789012345\rabcd" 22]
test io-6.35 {Tcl_GetsObj: auto mode: no chars} {
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line]
close $f
set x
} {-1 {}}
test io-6.36 {Tcl_GetsObj: auto mode: lone \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.37 {Tcl_GetsObj: auto mode: lone \r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.38 {Tcl_GetsObj: auto mode: \r\r} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" 0 "" -1 ""]
test io-6.39 {Tcl_GetsObj: auto mode: \r\n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} [list 0 "" -1 ""]
test io-6.40 {Tcl_GetsObj: auto mode: 1 char} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f a
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.41 {Tcl_GetsObj: auto mode: 1 char followed by EOL} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "a\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [gets $f line] $line [gets $f line] $line]
close $f
set x
} {1 a -1 {}}
test io-6.42 {Tcl_GetsObj: auto mode: several chars} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\nefgh\rijkl\r\nmnop"
close $f
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} {
# 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} {
# 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} {
# 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} {
# 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
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "\n\x1a"
lappend x [gets $f line] $line [testchannel queuedcr $f]
close $f
set x
} [list 15 "123456789abcdef" 1 -1 "" 0]
test io-6.47 {Tcl_GetsObj: auto mode: \r at end of buffer, peek for \n} {testchannel} {
# (eol == dstEnd)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r\nabcdefghijklmnopq"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 16
set x [list [gets $f] [testchannel inputbuffered $f]]
close $f
set x
} [list "123456789012345" 15]
test io-6.48 {Tcl_GetsObj: auto mode: \r at end of buffer, no more avail} {testchannel} {
# PeekAhead() did not get any, so (eol >= dstEnd)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456789012345\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -buffersize 16
set x [list [gets $f] [testchannel queuedcr $f]]
close $f
set x
} [list "123456789012345" 1]
test io-6.49 {Tcl_GetsObj: auto mode: \r followed by \n} {testchannel} {
# if (*eol == '\n') {skip++}
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\r\n78901"
close $f
set f [open $path(test1)]
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 8 "78901"]
test io-6.50 {Tcl_GetsObj: auto mode: \r not followed by \n} {testchannel} {
# not (*eol == '\n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\r78901"
close $f
set f [open $path(test1)]
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 7 "78901"]
test io-6.51 {Tcl_GetsObj: auto mode: \n} {
# else if (*eol == '\n') {goto gotoeol;}
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\n78901"
close $f
set f [open $path(test1)]
set x [list [gets $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 7 "78901"]
test io-6.52 {Tcl_GetsObj: saw EOF character} {testchannel} {
# if (eof != NULL)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "123456\x1ak9012345\r"
close $f
set f [open $path(test1)]
fconfigure $f -eofchar \x1a
set x [list [gets $f] [testchannel queuedcr $f] [tell $f] [gets $f]]
close $f
set x
} [list "123456" 0 6 ""]
test io-6.53 {Tcl_GetsObj: device EOF} {
# didn't produce any bytes
set f [open $path(test1) w]
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} {-1 {} 1}
test io-6.54 {Tcl_GetsObj: device EOF} {
# got some bytes before EOF.
set f [open $path(test1) w]
puts -nonewline $f abc
close $f
set f [open $path(test1)]
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} {3 abc 1}
test io-6.55 {Tcl_GetsObj: overconverted} {
# Tcl_ExternalToUtf(), make sure state updated
set f [open $path(test1) w]
fconfigure $f -encoding iso2022-jp
puts $f "there\u4e00ok\n\u4e01more bytes\nhere"
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} {
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 }]
fileevent $f readable [namespace code { lappend x [gets $f] }]
vwait [namespace which -variable x]
|
| ︙ | ︙ | |||
996 997 998 999 1000 1001 1002 |
close $f
set x
} {{} timeout foobarbaz timeout}
test io-7.1 {FilterInputBytes: split up character at end of buffer} {
# (result == TCL_CONVERT_MULTIBYTE)
| | | | | | | | | 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 |
close $f
set x
} {{} timeout foobarbaz timeout}
test io-7.1 {FilterInputBytes: split up character at end of buffer} {
# (result == TCL_CONVERT_MULTIBYTE)
set f [open $path(test1) w]
fconfigure $f -encoding shiftjis
puts $f "1234567890123\uff10\uff11\uff12\uff13\uff14\nend"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis -buffersize 16
set x [gets $f]
close $f
set x
} "1234567890123\uff10\uff11\uff12\uff13\uff14"
test io-7.2 {FilterInputBytes: split up character in middle of buffer} {
# (bufPtr->nextAdded < bufPtr->bufLength)
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890\n123\x82\x4f\x82\x50\x82"
close $f
set f [open $path(test1)]
fconfigure $f -encoding shiftjis
set x [list [gets $f line] $line [eof $f]]
close $f
set x
} [list 10 "1234567890" 0]
test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
set f [open $path(test1) w]
fconfigure $f -encoding binary
puts -nonewline $f "1234567890123\x82\x4f\x82\x50\x82"
close $f
set f [open $path(test1)]
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} {
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} {
variable x
|
| ︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 |
close $f
set x
} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0]
test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
# (bufPtr->nextPtr == NULL)
| | | | | | | | | | | 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 |
close $f
set x
} [list -1 "" 1 17 "1234567890123\uff10\uff11\uff12\uff13" 0]
test io-8.1 {PeekAhead: only go to device if no more cached data} {testchannel} {
# (bufPtr->nextPtr == NULL)
set f [open $path(test1) w]
fconfigure $f -encoding ascii -translation lf
puts -nonewline $f "123456789012345\r\n2345678"
close $f
set f [open $path(test1)]
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} {
# 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} {
# (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]]
close $f
set x
} [list 15 "abcdefghijklmno" 1]
set a "123456789012345678901234567890"
append a "123456789012345678901234567890"
append a "1234567890123456789012345678901"
test io-8.4 {PeekAhead: cached data available in this buffer} {
# not (bytesLeft == 0)
set f [open $path(test1) w+]
fconfigure $f -translation binary
puts $f "${a}\r\nabcdef"
close $f
set f [open $path(test1)]
fconfigure $f -encoding binary -translation auto
# "${a}\r" was converted in one operation (because ENCODING_LINESIZE
# is 30). To check if "\n" follows, calls PeekAhead and determines
# 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} {
# (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} {
# ((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} {
# 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]]
puts -nonewline $f "\x1a"
lappend x [gets $f line] $line
close $f
|
| ︙ | ︙ | |||
1169 1170 1171 1172 1173 1174 1175 |
test io-10.1 {Tcl_ReadChars: CheckChannelErrors} {
# no test, need to cause an async error.
} {}
test io-10.2 {Tcl_ReadChars: loop until enough copied} {
# one time
# for (copied = 0; (unsigned) toRead > 0; )
| | | | | | | | | | | | | | | | | | | | | | | | | 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 |
test io-10.1 {Tcl_ReadChars: CheckChannelErrors} {
# no test, need to cause an async error.
} {}
test io-10.2 {Tcl_ReadChars: loop until enough copied} {
# one time
# for (copied = 0; (unsigned) toRead > 0; )
set f [open $path(test1) w]
puts $f abcdefghijklmnop
close $f
set f [open $path(test1)]
set x [read $f 5]
close $f
set x
} {abcde}
test io-10.3 {Tcl_ReadChars: loop until enough copied} {
# multiple times
# for (copied = 0; (unsigned) toRead > 0; )
set f [open $path(test1) w]
puts $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -buffersize 16
# here
set x [read $f 19]
close $f
set x
} {abcdefghijklmnopqrs}
test io-10.4 {Tcl_ReadChars: no more in channel buffer} {
# (copiedNow < 0)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-10.5 {Tcl_ReadChars: stop on EOF} {
# (chanPtr->flags & CHANNEL_EOF)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-11.1 {ReadBytes: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
fconfigure $f -encoding binary
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-11.2 {ReadBytes: want to read all} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
fconfigure $f -encoding binary
# here
set x [read $f]
close $f
set x
} {abcdefghijkl}
test io-11.3 {ReadBytes: allocate more space} {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -buffersize 16 -encoding binary
# here
set x [read $f]
close $f
set x
} {abcdefghijklmnopqrstuvwxyz}
test io-11.4 {ReadBytes: EOF char found} {
# (TranslateInputEOL() != 0)
set f [open $path(test1) w]
puts $f abcdefghijklmnopqrstuvwxyz
close $f
set f [open $path(test1)]
fconfigure $f -eofchar m -encoding binary
# here
set x [list [read $f] [eof $f] [read $f] [eof $f]]
close $f
set x
} [list "abcdefghijkl" 1 "" 1]
test io-12.1 {ReadChars: want to read a lot} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f 1000]
close $f
set x
} {abcdefghijkl}
test io-12.2 {ReadChars: want to read all} {
# ((unsigned) toRead > (unsigned) srcLen)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijkl
close $f
set f [open $path(test1)]
# here
set x [read $f]
close $f
set x
} {abcdefghijkl}
test io-12.3 {ReadChars: allocate more space} {
# (toRead > length - offset - 1)
set f [open $path(test1) w]
puts -nonewline $f abcdefghijklmnopqrstuvwxyz
close $f
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} {
# (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
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
|
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 |
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} {
| | | | | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
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} {
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+]
fileevent $f readable [namespace code {
lappend x [read $f]
if {[eof $f]} {
lappend x eof
}
}]
puts $f "go1"
|
| ︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 |
vwait [namespace which -variable x]
vwait [namespace which -variable x]
lappend x [catch {close $f} msg] $msg
set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"
test io-13.1 {TranslateInputEOL: cr mode} {} {
| | | | | | | | | | | | | 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 |
vwait [namespace which -variable x]
vwait [namespace which -variable x]
lappend x [catch {close $f} msg] $msg
set x
} "{} timeout {} timeout \u7266 {} eof 0 {}"
test io-13.1 {TranslateInputEOL: cr mode} {} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\rdef\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation cr
set x [read $f]
close $f
set x
} "abcd\ndef\n"
test io-13.2 {TranslateInputEOL: crlf mode} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\n"
test io-13.3 {TranslateInputEOL: crlf mode: naked cr} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\r"
test io-13.4 {TranslateInputEOL: crlf mode: cr followed by not \n} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\rfgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation crlf
set x [read $f]
close $f
set x
} "abcd\ndef\rfgh"
test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef\nfgh"
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} {
# (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"]
proc ready {f} {
variable x
lappend x [read $f] [testchannel queuedcr $f]
}
|
| ︙ | ︙ | |||
1459 1460 1461 1462 1463 1464 1465 |
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel} {
# (src >= srcMax)
| | | | | | | | | | | | | | 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 |
close $f
set x
} [list "abcdefghj\n" 1 "01234" 0]
test io-13.7 {TranslateInputEOL: auto mode: naked \r} {testchannel} {
# (src >= srcMax)
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [list [read $f] [testchannel queuedcr $f]]
close $f
set x
} [list "abcd\n" 1]
test io-13.8 {TranslateInputEOL: auto mode: \r\n} {
# (*src == '\n')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\r\ndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.9 {TranslateInputEOL: auto mode: \r followed by not \n} {
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\rdef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.10 {TranslateInputEOL: auto mode: \n} {
# not (*src == '\r')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\ndef"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto
set x [read $f]
close $f
set x
} "abcd\ndef"
test io-13.11 {TranslateInputEOL: EOF char} {
# (*chanPtr->inEofChar != '\0')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "abcd\ndefgh"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
set x
} "abcd\nd"
test io-13.12 {TranslateInputEOL: find EOF char in src} {
# (*chanPtr->inEofChar != '\0')
set f [open $path(test1) w]
fconfigure $f -translation lf
puts -nonewline $f "\r\n\r\n\r\nab\r\n\r\ndef\r\n\r\n\r\n"
close $f
set f [open $path(test1)]
fconfigure $f -translation auto -eofchar e
set x [read $f]
close $f
set x
} "\n\n\nab\n\nd"
# Test standard handle management. The functions tested are
|
| ︙ | ︙ | |||
1565 1566 1567 1568 1569 1570 1571 |
set l ""
lappend l [x eval {fconfigure stdin -buffering}]
lappend l [x eval {fconfigure stdout -buffering}]
lappend l [x eval {fconfigure stderr -buffering}]
interp delete x
set l
} {line line none}
| > > > | | | | | | | | | | | | | | | | | | | | | 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 |
set l ""
lappend l [x eval {fconfigure stdin -buffering}]
lappend l [x eval {fconfigure stdout -buffering}]
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} {
set f [open $path(test1) w]
puts $f [format {
close stdin
close stdout
close stderr
set f [open "%s" r]
set f2 [open "%s" w]
set f3 [open "%s" w]
puts stdout [gets stdin]
puts stdout out
puts stderr err
close $f
close $f2
close $f3
} $path(test1) $path(test2) $path(test3)]
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 $f [format { close stdin
close stdout
close stderr
set f [open "%s" r]
set f2 [open "%s" w]
set f3 [open "%s" w]
puts stdout [gets stdin]
puts stdout $f2
puts stderr $f3
close $f
close $f2
close $f3
} $path(test1) $path(test2) $path(test3)]
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
} {{ close stdin
file1
} {file2
|
| ︙ | ︙ | |||
1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 |
catch {z eval flush stderr} msg1
catch {z eval close stderr} msg2
catch {z eval flush stderr} msg3
set result [list $msg1 $msg2 $msg3]
interp delete z
set result
} {{} {} {can not find channel named "stderr"}}
test io-14.8 {reuse of stdio special channels} {stdio} {
removeFile script
removeFile test1
| > > > | | | | | | > | > | | | | 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 |
catch {z eval flush stderr} msg1
catch {z eval close stderr} msg2
catch {z eval flush stderr} msg3
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} {
removeFile script
removeFile test1
set f [open $path(script) w]
puts $f [format {
close stderr
set f [open "%s" w]
puts stderr hello
close $f
set f [open "%s" r]
puts [gets $f]
} $path(test1) $path(test1)]
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} {
removeFile script
removeFile 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
set c
} hello
test io-15.1 {Tcl_CreateCloseHandler} {
} {}
|
| ︙ | ︙ | |||
1742 1743 1744 1745 1746 1747 1748 |
lappend l [expr [testchannel refcount stderr] - $l1]
set l
} {0 1 0}
test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
removeFile test1
set l ""
| | | | | 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 |
lappend l [expr [testchannel refcount stderr] - $l1]
set l
} {0 1 0}
test io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} {
removeFile 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} {
removeFile 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} {
removeFile 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
lappend l [lindex [testchannel info $f] 15]
close $f
|
| ︙ | ︙ | |||
1799 1800 1801 1802 1803 1804 1805 |
} 0
test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
eof stdin
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
removeFile test1
| | | | | | | | > > > | | | | | | | | | | | 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 |
} 0
test io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} {
eof stdin
} 0
test io-19.2 {testing Tcl_GetChannel, user opened handle} {
removeFile 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} {
removeFile 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 {
lappend l "very broken: $f found after being closed"
}
string compare [string tolower $l] \
[list 0 [format "can not find channel named \"%s\"" $f]]
} 0
test io-20.1 {Tcl_CreateChannel: initial settings} {
set a [open $path(test2) w]
set old [encoding system]
encoding system ascii
set f [open $path(test1) w]
set x [fconfigure $f -encoding]
close $f
encoding system $old
close $a
set x
} {ascii}
test io-20.2 {Tcl_CreateChannel: initial settings} {pcOnly} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} [list [list \x1a ""] {auto crlf}]
test io-20.3 {Tcl_CreateChannel: initial settings} {unixOnly} {
set f [open $path(test1) w+]
set x [list [fconfigure $f -eofchar] [fconfigure $f -translation]]
close $f
set x
} {{{} {}} {auto lf}}
test io-20.4 {Tcl_CreateChannel: initial settings} {macOnly} {
set f [open $path(test1) w+]
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} {
set f [open $path(script) w]
puts $f [format {
close stdout
set f1 [open "%s" w]
fconfigure $f1 -buffersize 777
puts stderr [fconfigure stdout -buffersize]
} $path(stdout)]
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} {
removeFile 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} {
removeFile 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} {
removeFile 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]
|
| ︙ | ︙ | |||
1936 1937 1938 1939 1940 1941 1942 |
close $f
} {}
# Test flushing. The functions tested here are FlushChannel.
test io-27.1 {FlushChannel, no output buffered} {
removeFile test1
| | | | | | | | | | | | | | | | | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
close $f
} {}
# Test flushing. The functions tested here are FlushChannel.
test io-27.1 {FlushChannel, no output buffered} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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 } {
removeFile pipe
removeFile output
set f [open $path(pipe) w]
puts $f [format {
set f [open "%s" w]
fconfigure $f -translation lf -buffering none -eofchar {}
while {![eof stdin]} {
after 20
puts -nonewline $f [read stdin 1024]
}
close $f
} $path(output)]
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
set f [open "|[list [interpreter] $path(pipe)]" w]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
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} {
removeFile 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} {
removeFile 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} {
removeFile pipe
removeFile 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".
fconfigure stdout -eofchar {}
fconfigure stderr -eofchar {}
set f [open $path(output) w]
fconfigure $f -translation lf -buffering none
for {set x 0} {$x < 20} {incr x} {
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
set f [open "|[list [interpreter] pipe]" r+]
fconfigure $f -blocking off -eofchar {}
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 20480) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
set result probably_broken
} else {
set result ok
}
} ok
test io-28.4 {Tcl_Close} {testchannel} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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
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 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} {
removeFile 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} {
removeFile 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} {
removeFile test1
removeFile pipe
set f1 [open $path(pipe) w]
puts $f1 [format {
set f1 [open "%s" r]
for {set x 0} {$x < 10} {incr x} {
puts [gets $f1]
}
} $path(longfile)]
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} {
removeFile test1
removeFile pipe
set f1 [open $path(pipe) w]
puts $f1 {
puts [gets stdin]
puts [gets stdin]
}
close $f1
set y ok
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -buffering line
set f2 [open $path(longfile) r]
set line [gets $f2]
puts $f1 $line
set backline [gets $f1]
if {"$line" != "$backline"} {
set y broken
}
set line [gets $f2]
puts $f1 $line
set backline [gets $f1]
if {"$line" != "$backline"} {
set y broken
}
close $f1
close $f2
set y
} ok
test io-29.14 {Tcl_WriteChars, buffering and implicit flush at close} {
removeFile 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} {
removeFile 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} {
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile pipe
set f1 [open $path(pipe) w]
puts $f1 {
fconfigure stdout -buffering full
puts hello
puts hello
flush stdout
gets stdin
puts bye
flush stdout
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set x ""
lappend x [gets $f1]
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} {
removeFile pipe
set f1 [open $path(pipe) w]
puts $f1 {
puts hello
puts hello
gets stdin
puts bye
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set x ""
lappend x [gets $f1]
lappend x [gets $f1]
puts $f1 hello
flush $f1
lappend x [gets $f1]
close $f1
set x
} {hello hello bye}
test io-29.24 {Tcl_WriteChars and Tcl_Flush move end of file} {
set f [open $path(test3) w]
puts $f "Line 1"
puts $f "Line 2"
set f2 [open $path(test3)]
set x {}
lappend x [read -nonewline $f2]
close $f2
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} {
removeFile 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} {
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} {
removeFile 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
#
# The flush below will get a SIGPIPE. This is an expected part of
# test and indicates that the test operates correctly. If you run
# this test under a debugger, the signal will by intercepted unless
|
| ︙ | ︙ | |||
2536 2537 2538 2539 2540 2541 2542 |
}
}
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
removeFile test1
| | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
}
}
regsub {".*":} $x {"":} x
string tolower $x
} {1 {error flushing "": broken pipe} {posix epipe {broken pipe}}}
test io-29.28 {Tcl_WriteChars, lf mode} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile pipe
removeFile output
set f [open $path(pipe) w]
puts $f [format {set f [open "%s" w]} $path(output)]
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 "}"
puts $f {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
set f [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 5
update
}
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} {
removeFile pipe
removeFile output
set f [open $path(pipe) w]
puts $f [format {set f [open "%s" w]} $path(output)]
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}
puts $f "}"
puts $f {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
set f [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f -blocking off
puts -nonewline $f $x
close $f
set counter 0
while {([file size $path(output)] < 65536) && ($counter < 1000)} {
incr counter
after 20
update
}
if {$counter == 1000} {
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 [format {
set f [open "%s" w]
fconfigure $f -translation lf
puts $f hello
puts $f bye
puts $f strange
} $path(test1)]
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} {
set c 0
variable x running
|
| ︙ | ︙ | |||
2733 2734 2735 2736 2737 2738 2739 |
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} {
removeFile test1
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > | | | | | | | | | | | | 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 |
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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 {}
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]
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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 {}
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]
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} {
removeFile 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 {}
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]
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} {
removeFile 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 {}
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]
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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 ""
while {[gets $f line] >= 0} {
append c $line\n
}
close $f
string length $c
} [expr 700*15+1]
# Test Tcl_Read and buffering.
test io-32.1 {Tcl_Read, channel not readable} {
list [catch {read stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test io-32.2 {Tcl_Read, zero byte count} {
read stdin 0
} ""
test io-32.3 {Tcl_Read, negative byte count} {
set f [open $path(longfile) r]
set l [list [catch {read $f -1} msg] $msg]
close $f
set l
} {1 {bad argument "-1": should be "nonewline"}}
test io-32.4 {Tcl_Read, positive byte count} {
set f [open $path(longfile) r]
set x [read $f 1024]
set s [string length $x]
unset x
close $f
set s
} 1024
test io-32.5 {Tcl_Read, multiple buffers} {
set f [open $path(longfile) r]
fconfigure $f -buffersize 100
set x [read $f 1024]
set s [string length $x]
unset x
close $f
set s
} 1024
test io-32.6 {Tcl_Read, very large read} {
set f1 [open $path(longfile) r]
set z [read $f1 1000000]
close $f1
set l [string length $z]
set x ok
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.7 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set f1 [open $path(longfile) r]
fconfigure $f1 -blocking off
set z [read $f1 20]
close $f1
set l [string length $z]
set x ok
if {$l != 20} {
set x broken
}
set x
} ok
test io-32.8 {Tcl_Read, nonblocking, file} {nonBlockFiles} {
set f1 [open $path(longfile) r]
fconfigure $f1 -blocking off
set z [read $f1 1000000]
close $f1
set x ok
set l [string length $z]
set z [file size $path(longfile)]
if {$z != $l} {
set x broken
}
set x
} ok
test io-32.9 {Tcl_Read, read to end of file} {
set f1 [open $path(longfile) r]
set z [read $f1]
close $f1
set l [string length $z]
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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
if {"$x" != "$y"} {
set z broken
}
close $f1
set z
} ok
test io-33.2 {Tcl_Gets into variable} {
set f1 [open $path(longfile) r]
set c [gets $f1 x]
set l [string length x]
set z ok
if {$l != $l} {
set z broken
}
close $f1
set z
} ok
test io-33.3 {Tcl_Gets from pipe} {stdio} {
removeFile 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} {
removeFile 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} {
removeFile 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
set y {}
lappend x [gets $f y] $y
set y {}
lappend x [gets $f y] $y
close $f
set x
} {5 Test1 5 Test2 -1 {}}
test io-33.7 {Tcl_Gets and bad variable} {
set f [open $path(test3) w]
puts $f "Line 1"
puts $f "Line 2"
close $f
catch {unset x}
set x 24
set f [open $path(test3) r]
set result [list [catch {gets $f x(0)} msg] $msg]
close $f
set result
} {1 {can't set "x(0)": variable isn't array}}
test io-33.8 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 100} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 100} {incr y} {gets $f}
close $f
set y
} 100
test io-33.9 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 200} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 200} {incr y} {gets $f}
close $f
set y
} 200
test io-33.10 {Tcl_Gets, exercising double buffering} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
set x ""
for {set y 0} {$y < 99} {incr y} {set x "a$x"}
for {set y 0} {$y < 300} {incr y} {puts $f $x}
close $f
set f [open $path(test3) r]
fconfigure $f -translation lf
for {set y 0} {$y < 300} {incr y} {gets $f}
close $f
set y
} 300
# Test Tcl_Seek and Tcl_Tell.
test io-34.1 {Tcl_Seek to current position at start of file} {
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
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} {
removeFile 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
lappend x [read $f 1]
seek $f 0 start
lappend x [read $f 1]
seek $f 10 current
lappend x [read $f 1]
seek $f -2 end
lappend x [read $f 1]
seek $f 50 end
lappend x [read $f 1]
seek $f 1
lappend x [read $f 1]
close $f
set x
} {a d a l Y {} b}
set path(test3) [makeFile {} test3]
test io-34.10 {Tcl_Seek testing flushing of buffered input} {
set f [open $path(test3) w]
fconfigure $f -translation lf
puts $f xyz\n123
close $f
set f [open $path(test3) r+]
fconfigure $f -translation lf
set x [gets $f]
seek $f 0 current
puts $f 456
close $f
list $x [viewFile test3]
} "xyz {xyz
456}"
test io-34.11 {Tcl_Seek testing flushing of buffered output} {
set f [open $path(test3) w]
puts $f xyz\n123
close $f
set f [open $path(test3) w+]
puts $f xyzzy
seek $f 2
set x [gets $f]
close $f
list $x [viewFile test3]
} "zzy xyzzy"
test io-34.12 {Tcl_Seek testing combination of write, seek back and read} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
puts $f xyz\n123
close $f
set f [open $path(test3) a+]
fconfigure $f -translation lf -eofchar {}
puts $f xyzzy
flush $f
set x [tell $f]
seek $f -4 cur
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} {
removeFile 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} {
removeFile 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} {
removeFile 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}
|
| ︙ | ︙ | |||
4284 4285 4286 4287 4288 4289 4290 |
set c [tell $f1]
gets $f1
close $f1
set c
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
removeFile test2
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
set c [tell $f1]
gets $f1
close $f1
set c
} -1
test io-34.18 {Tcl_Tell combined with seeking and reading} {
removeFile 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]
read $f 3
lappend x [tell $f]
seek $f 2
lappend x [tell $f]
seek $f 10 current
lappend x [tell $f]
seek $f 0 end
lappend x [tell $f]
close $f
set x
} {0 3 2 12 30}
test io-34.19 {Tcl_Tell combined with opening in append mode} {
set f [open $path(test3) w]
fconfigure $f -translation lf -eofchar {}
puts $f "abcdefghijklmnopqrstuvwxyz"
puts $f "abcdefghijklmnopqrstuvwxyz"
close $f
set f [open $path(test3) a]
set c [tell $f]
close $f
set c
} 54
test io-34.20 {Tcl_Tell combined with writing} {
set f [open $path(test3) w]
set l ""
seek $f 29 start
lappend l [tell $f]
puts -nonewline $f a
seek $f 39 start
lappend l [tell $f]
puts -nonewline $f a
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} {
removeFile 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
lappend l [tell $f]
# 4GB offset!
seek $f 0x100000000
lappend l [tell $f]
puts -nonewline $f abcdef
lappend l [tell $f]
close $f
lappend l [file size $f]
# truncate...
close [open $path(test3) w]
lappend l [file size $f]
set l
} {0 6 6 4294967296 4294967302 4294967302 0}
# Test Tcl_Eof
test io-35.1 {Tcl_Eof} {
removeFile 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} {
removeFile 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} {
removeFile 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]
gets $f1
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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}
|
| ︙ | ︙ | |||
4650 4651 4652 4653 4654 4655 4656 |
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} {
removeFile test1
| | | | | | | | | | | | | | 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 |
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} {
removeFile 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} {
proc in {f} {
variable l
variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
removeFile 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} {
removeFile 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} {
proc in {f} {
variable l
variable x
lappend l [read $f 3]
if {[eof $f]} {lappend l eof; close $f; set x done}
}
removeFile 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]]
variable x
vwait [namespace which -variable x]
set l
} {abc def ghi jkl mno {p
} eof}
# Test Tcl_InputBuffered
test io-37.1 {Tcl_InputBuffered} {testchannel} {
set f [open $path(longfile) r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {4093 3}
test io-37.2 {Tcl_InputBuffered, test input flushing on seek} {testchannel} {
set f [open $path(longfile) r]
fconfigure $f -buffersize 4096
read $f 3
set l ""
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
seek $f 0 current
lappend l [testchannel inputbuffered $f]
lappend l [tell $f]
close $f
set l
} {4093 3 0 3}
# Test Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize
test io-38.1 {Tcl_GetChannelBufferSize, default buffer size} {
set f [open $path(longfile) r]
set s [fconfigure $f -buffersize]
close $f
set s
} 4096
test io-38.2 {Tcl_SetChannelBufferSize, Tcl_GetChannelBufferSize} {
set f [open $path(longfile) r]
set l ""
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 10000
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize 1
lappend l [fconfigure $f -buffersize]
fconfigure $f -buffersize -1
|
| ︙ | ︙ | |||
4790 4791 4792 4793 4794 4795 4796 |
close $chan
} {}
# Test Tcl_SetChannelOption, Tcl_GetChannelOption
test io-39.1 {Tcl_GetChannelOption} {
removeFile test1
| | | | | | | | | | | | | | | | | | | | | | | 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 |
close $chan
} {}
# Test Tcl_SetChannelOption, Tcl_GetChannelOption
test io-39.1 {Tcl_GetChannelOption} {
removeFile 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} {
removeFile test1
set f1 [open $path(test1) w]
set x [fconfigure $f1 -buffering]
close $f1
set x
} full
test io-39.3 {Tcl_GetChannelOption} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile pipe
set f1 [open $path(pipe) w]
puts $f1 {
gets stdin
after 100
puts hi
gets stdin
}
close $f1
set x ""
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -blocking off -buffering line
lappend x [fconfigure $f1 -blocking]
lappend x [gets $f1]
lappend x [fblocked $f1]
fconfigure $f1 -blocking on
puts $f1 hello
fconfigure $f1 -blocking off
|
| ︙ | ︙ | |||
4937 4938 4939 4940 4941 4942 4943 |
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} {
removeFile test1
| | | | | | | | | | | 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 |
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
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] }]
vwait [namespace which -variable x]
|
| ︙ | ︙ | |||
5068 5069 5070 5071 5072 5073 5074 |
close $s1
close $s2
set modes
} {auto crlf}
test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
removeFile test1
| | | | 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 |
close $s1
close $s2
set modes
} {auto crlf}
test io-39.22 {Tcl_SetChannelOption, invariance} {unixOnly} {
removeFile 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} {
removeFile 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]
close $f1
|
| ︙ | ︙ | |||
5113 5114 5115 5116 5117 5118 5119 |
lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
close $sock
set l
} {{{}} auto}
test io-40.1 {POSIX open access modes: RDWR} {
removeFile test3
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
close $sock
set l
} {{{}} auto}
test io-40.1 {POSIX open access modes: RDWR} {
removeFile 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} {
removeFile 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.
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile test3
set f [open $path(test3) w]
puts $f xyzzy
close $f
set msg [list [catch {open $path(test3) {WRONLY CREAT EXCL}} msg] $msg]
regsub " already " $msg " " msg
regsub [file join {} $path(test3)] $msg "test3" msg
string tolower $msg
} {1 {couldn't open "test3": file exists}}
test io-40.7 {POSIX open access modes: EXCL} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile test3
set msg [list [catch {open $path(test3) RDONLY} msg] $msg]
regsub [file join {} $path(test3)] $msg "test3" msg
string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test io-40.12 {POSIX open access modes: WRONLY} {
removeFile test3
set msg [list [catch {open $path(test3) WRONLY} msg] $msg]
regsub [file join {} $path(test3)] $msg "test3" msg
string tolower $msg
} {1 {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} {
removeFile test3
set msg [list [catch {open $path(test3) RDWR} msg] $msg]
regsub [file join {} $path(test3)] $msg "test3" msg
string tolower $msg
} {1 {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 ~]} {
|
| ︙ | ︙ | |||
5317 5318 5319 5320 5321 5322 5323 |
list [catch {fileevent gorp who-knows} msg] $msg
} {1 {bad event name "who-knows": must be readable or writable}}
#
# Test fileevent on a file
#
| > | | 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 |
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} {
list [fileevent $f readable] [fileevent $f writable]
} {{} {}}
test io-42.2 {Tcl_FileeventCmd: replacing} {
set result {}
fileevent $f r "first script"
|
| ︙ | ︙ | |||
5420 5421 5422 5423 5424 5425 5426 |
fileevent $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
rename ::bgerror {}
list $x [fileevent $f2 writable]
} {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs} {
| | | 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 |
fileevent $f2 writable {error bad-write}
variable x initial
vwait [namespace which -variable x]
rename ::bgerror {}
list $x [fileevent $f2 writable]
} {bad-write {}}
test io-44.5 {FileEventProc procedure: end of file} {stdio unixExecs} {
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
}
|
| ︙ | ︙ | |||
5443 5444 5445 5446 5447 5448 5449 |
catch {close $f2}
catch {close $f3}
close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {
| | | | | | | | 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 |
catch {close $f2}
catch {close $f3}
close $f
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {
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} {
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} {
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 {}
close $f2
lappend x [catch {fileevent $f readable} msg] $msg \
[catch {fileevent $f2 readable}] \
|
| ︙ | ︙ | |||
5499 5500 5501 5502 5503 5504 5505 |
} {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} {
testfevent create
| | | | | 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 |
} {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} {
testfevent create
testfevent cmd [format {
set f [open %s r]
set x "no event"
fileevent $f readable [namespace code {
set x "f triggered: [gets $f]"
fileevent $f readable {}
}]
} $path(foo)]
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
|
| ︙ | ︙ | |||
5536 5537 5538 5539 5540 5541 5542 |
lappend result $x
update
lappend result $x
}
} {0 0 {0 timer}}
test io-47.1 {fileevent vs multiple interpreters} testfevent {
| | | | | | | | | | | | | | | | > > | | | | > > > | | | 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 |
lappend result $x
update
lappend result $x
}
} {0 0 {0 timer}}
test io-47.1 {fileevent vs multiple interpreters} testfevent {
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 {
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 {
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 {
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 {
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 {
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} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
set f [open $path(bar) r]
fileevent $f readable [namespace code [list consume $f]]
proc consume {f} {
variable l
variable x
lappend l called
if {[eof $f]} {
close $f
set x done
} else {
gets $f
}
}
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} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
set f [open $path(bar) r]
fileevent $f readable [namespace code [list consume $f]]
fconfigure $f -blocking off
proc consume {f} {
variable x
variable l
lappend l called
if {[eof $f]} {
close $f
set x done
} else {
gets $f
}
}
set l ""
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} {
set f [open $path(bar) w]
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
puts $f abcdefg
close $f
set f [open $path(my_script) w]
puts $f {
proc copy_slowly {f} {
while {![eof $f]} {
puts [gets $f]
after 200
}
close $f
|
| ︙ | ︙ | |||
5729 5730 5731 5732 5733 5734 5735 |
lappend l [fblocked $f]
gets $f
lappend l [fblocked $f]
}
}
set l ""
variable x not_done
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
lappend l [fblocked $f]
gets $f
lappend l [fblocked $f]
}
}
set l ""
variable x not_done
puts $f [format {source %s} $path(my_script)]
puts $f [format {set f [open %s r]} $path(bar)]
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} {
removeFile 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
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable c
variable x
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable x
variable c
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable x
variable l
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable x
variable l
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
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} {
removeFile 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
variable x
variable l
if {[eof $f]} {
set x done
close $f
} else {
lappend l [gets $f]
incr c
}
}
set c 0
set l ""
set f [open $path(test1) r]
fconfigure $f -translation crlf -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-49.1 {testing crlf reading, leftover cr disgorgment} {
removeFile 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 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
lappend l [read $f 1]
lappend l [tell $f]
|
| ︙ | ︙ | |||
6105 6106 6107 6108 6109 6110 6111 |
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} {
removeFile test1
| | | | | | | | | | | | | | | | | | | | 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 |
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} {
removeFile 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 2]
lappend l [tell $f]
lappend l [read $f 2]
lappend l [tell $f]
lappend l [read $f 2]
lappend l [tell $f]
lappend l [eof $f]
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
variable z
lappend z "notcalled was called!! $f $i"
}
|
| ︙ | ︙ | |||
6250 6251 6252 6253 6254 6255 6256 |
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} {
removeFile test1
| | | | 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 |
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} {
removeFile 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
if {"$u" == "recursive"} {
testchannelevent $f delete 0
lappend z "delrecursive deleting recursive"
|
| ︙ | ︙ | |||
6275 6276 6277 6278 6279 6280 6281 |
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} {
removeFile test1
| | | | 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 |
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} {
removeFile 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
lappend z "notcalled was called!! $f"
}
proc del {f} {
|
| ︙ | ︙ | |||
6309 6310 6311 6312 6313 6314 6315 |
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} {
removeFile test1
| | | | 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 |
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} {
removeFile 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
variable z
if {"$u" == "toplevel"} {
lappend z "first called"
|
| ︙ | ︙ | |||
6393 6394 6395 6396 6397 6398 6399 |
close $ss
set result
} {sock1 sock2 sock3 sock4}
test io-52.1 {TclCopyChannel} {
removeFile test1
set f1 [open $thisScript]
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
close $ss
set result
} {sock1 sock2 sock3 sock4}
test io-52.1 {TclCopyChannel} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile test1
removeFile 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
puts \[read \$f1 100\]
close \$f1
"
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
fconfigure $f1 -translation lf
gets $f1
puts $f1 ready
flush $f1
set f2 [open $path(test1) w]
fconfigure $f2 -translation lf
set s0 [fcopy $f1 $f2 -size 40]
catch {close $f1}
close $f2
list $s0 [file size $path(test1)]
} {40 40}
# Empty files, to register them with the test facility
set path(kyrillic.txt) [makeFile {} kyrillic.txt]
set path(utf8-fcopy.txt) [makeFile {} utf8-fcopy.txt]
set path(utf8-rp.txt) [makeFile {} utf8-rp.txt]
# 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} {
# 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
fcopy $in $out
close $in
close $out
# Do the same again, but differently (read/puts).
set in [open $path(kyrillic.txt) r]
set out [open $path(utf8-rp.txt) w]
fconfigure $in -encoding koi8-r -translation lf
fconfigure $out -encoding utf-8 -translation lf
puts -nonewline $out [read $in]
close $in
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} {
# 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} {
# 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} {
removeFile 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} {
removeFile 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} {
removeFile test1
removeFile pipe
set f1 [open $path(pipe) w]
puts $f1 [format {
puts ready
flush stdout ;# Don't assume line buffered!
fcopy stdin stdout -command { set x }
vwait x
set f [open "%s" w]
fconfigure $f -translation lf
puts $f "done"
close $f
} $path(test1)]
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} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
removeFile test1
removeFile 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
puts $f "done"
close $f
}
close $f1
set f1 [open "|[list [interpreter] $path(pipe)]" r+]
set result [gets $f1]
fconfigure $f1 -blocking 0
puts $f1 $big
flush $f1
after 500
set result ""
fileevent $f1 read [namespace code {
|
| ︙ | ︙ | |||
6731 6732 6733 6734 6735 6736 6737 |
set fcopyTestDone ;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio} {
variable fcopyTestDone
removeFile pipe
removeFile test1
catch {unset fcopyTestDone}
| | | | | 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 |
set fcopyTestDone ;# 1 for error condition
} 1
test io-53.6 {CopyData: error during fcopy} {stdio} {
variable fcopyTestDone
removeFile pipe
removeFile 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]
variable fcopyTestDone
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone]
}
catch {close $in}
close $out
|
| ︙ | ︙ | |||
6769 6770 6771 6772 6773 6774 6775 |
test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio} {
variable fcopyTestDone
removeFile pipe
removeFile test1
catch {unset fcopyTestDone}
set fcopyTestCount 0
| | | | | 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 |
test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio} {
variable fcopyTestDone
removeFile pipe
removeFile test1
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"
if {[incr count -1]} {
after 10 [list Write $count]
} else {
set ::ready 1
}
}
fconfigure stdout -buffering none
Write 345 ;# 3450 bytes ~3.45 sec
vwait ready
exit 0
}
close $f1
set in [open "|[list [interpreter] $path(pipe) &]" r+]
set out [open $path(test1) w]
doFcopy $in $out
variable fcopyTestDone
if ![info exists fcopyTestDone] {
vwait [namespace which -variable fcopyTestDone]
}
catch {close $in}
close $out
|
| ︙ | ︙ | |||
6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 |
vwait [namespace which -variable done]
close $writer
close $s
after cancel $after
if {$accept != {}} {close $accept}
set counter
} 1
test io-55.1 {ChannelEventScriptInvoker: deletion} {
variable x
proc eventScript {fd} {
variable x
close $fd
error "planned error"
set x whoops
}
proc ::bgerror {args} "set [namespace which -variable x] got_error"
| > > | | | | 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 |
vwait [namespace which -variable done]
close $writer
close $s
after cancel $after
if {$accept != {}} {close $accept}
set counter
} 1
set path(fooBar) [makeFile {} fooBar]
test io-55.1 {ChannelEventScriptInvoker: deletion} {
variable x
proc eventScript {fd} {
variable x
close $fd
error "planned error"
set x whoops
}
proc ::bgerror {args} "set [namespace which -variable x] got_error"
set f [open $path(fooBar) w]
fileevent $f writable [namespace code [list eventScript $f]]
variable x not_done
vwait [namespace which -variable x]
set x
} {got_error}
test io-56.1 {ChannelTimerProc} {testchannelevent} {
set f [open $path(fooBar) w]
puts $f "this is a test"
close $f
set f [open $path(fooBar) r]
testchannelevent $f add readable [namespace code {
read $f 1
incr x
}]
variable x 0
vwait [namespace which -variable x]
vwait [namespace which -variable x]
|
| ︙ | ︙ | |||
6998 6999 7000 7001 7002 7003 7004 |
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc} {
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc} {
set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
variable x
variable result
if {[eof $pipe]} {
set x [catch {close $pipe} line]
lappend result catch $line
} else {
gets $pipe line
lappend result gets $line
}
}
close $out
set pipe [open "|[list [interpreter] $path(script)]" r]
fileevent $pipe readable [namespace code [list readit $pipe]]
variable x ""
set result ""
vwait [namespace which -variable x]
list $x $result
} {1 {gets {normal message from pipe} gets {} catch {error message from pipe}}}
testConstraint testmainthread [llength [info commands testmainthread]]
test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
# TIP #10
# More complicated tests (like that the reference changes as a
# channel is moved from thread to thread) can be done only in the
# extension which fully implements the moving of channels between
# threads, i.e. 'Threads'. Or we have to extend [testthread] as well.
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} {
# 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
}
proc readit {pipe} {
variable x
variable result
if {[eof $pipe]} {
set x [catch {close $pipe} line]
lappend result catch $line
} else {
gets $pipe line
lappend result gets $line
}
}
close $out
set pipe [open "|[list [interpreter] $path(script)]" r]
fileevent $pipe readable [namespace code [list readit $pipe]]
variable x ""
set result ""
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}}}
# cleanup
foreach file [list fooBar longfile script output test1 pipe my_script foo \
bar test2 test3 cat stdout] {
removeFile $file
}
cleanupTests
}
namespace delete ::tcl::test::io
return
|
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # 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. # | | < < > > > | | | | | | | 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 |
# 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.11.2.2 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
removeFile test1
removeFile pipe
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"}}
test iocmd-1.3 {puts command} {
list [catch {puts froboz -nonewline kablooie} msg] $msg
} {1 {bad argument "kablooie": should be "nonewline"}}
test iocmd-1.4 {puts command} {
list [catch {puts froboz hello} msg] $msg
} {1 {can not find channel named "froboz"}}
test iocmd-1.5 {puts command} {
list [catch {puts stdin hello} msg] $msg
} {1 {channel "stdin" wasn't opened for writing}}
set path(test1) [makeFile {} test1]
test iocmd-1.6 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts -nonewline $f foobar
close $f
file size $path(test1)
} 6
test iocmd-1.7 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts $f foobar
close $f
file size $path(test1)
} 7
test iocmd-1.8 {puts command} {
set f [open $path(test1) w]
fconfigure $f -translation lf -eofchar {}
puts -nonewline $f [binary format a4a5 foo bar]
close $f
file size $path(test1)
} 9
test iocmd-2.1 {flush command} {
list [catch {flush} msg] $msg
} {1 {wrong # args: should be "flush channelId"}}
test iocmd-2.2 {flush command} {
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
test iocmd-3.3 {gets command} {
list [catch {gets aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-3.4 {gets command} {
list [catch {gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-3.5 {gets command} {
| | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
test iocmd-3.3 {gets command} {
list [catch {gets aaa} msg] $msg
} {1 {can not find channel named "aaa"}}
test iocmd-3.4 {gets command} {
list [catch {gets stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-3.5 {gets command} {
set f [open $path(test1) w]
puts $f [binary format a4a5 foo bar]
close $f
set f [open $path(test1) r]
set result [gets $f]
close $f
set x foo\x00
set x "${x}bar\x00\x00"
string compare $x $result
} 0
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
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} {
removeFile test1
| | | > > > | | | 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 |
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} {
removeFile 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
set x
} {1 {wrong # args: should be "read channelId ?numChars?" or "read ?-nonewline? channelId"} NONE}
test iocmd-4.9 {read command} {
list [catch {read stdin foo} msg] $msg $errorCode
} {1 {bad argument "foo": should be "nonewline"} NONE}
test iocmd-4.10 {read command} {
list [catch {read file107} msg] $msg $errorCode
} {1 {can not find channel named "file107"} NONE}
set path(test3) [makeFile {} test3]
test iocmd-4.11 {read command} {
set f [open $path(test3) w]
set x [list [catch {read $f} msg] $msg $errorCode]
close $f
string compare [string tolower $x] \
[list 1 [format "channel \"%s\" wasn't opened for reading" $f] none]
} 0
test iocmd-4.12 {read command} {
set f [open $path(test1)]
set x [list [catch {read $f 12z} msg] $msg $errorCode]
close $f
set x
} {1 {expected integer but got "12z"} NONE}
test iocmd-5.1 {seek command} {
list [catch {seek} msg] $msg
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
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} {
removeFile test1
| | | | | | | | | | 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 |
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} {
removeFile 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} {
removeFile 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} {
removeFile 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} {
removeFile 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}
test iocmd-8.10 {fconfigure command} {
list [catch {fconfigure a b} msg] $msg
} {1 {can not find channel named "a"}}
set path(fconfigure.dummy) [makeFile {} fconfigure.dummy]
test iocmd-8.11 {fconfigure command} {
set chan [open $path(fconfigure.dummy) r]
set res [list [catch {fconfigure $chan -froboz blarfo} msg] $msg]
close $chan
set res
} {1 {bad option "-froboz": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.12 {fconfigure command} {
set chan [open $path(fconfigure.dummy) r]
set res [list [catch {fconfigure $chan -b blarfo} msg] $msg]
close $chan
set res
} {1 {bad option "-b": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
test iocmd-8.13 {fconfigure command} {
set chan [open $path(fconfigure.dummy) r]
set res [list [catch {fconfigure $chan -buffer blarfo} msg] $msg]
close $chan
set res
} {1 {bad option "-buffer": should be one of -blocking, -buffering, -buffersize, -encoding, -eofchar, or -translation}}
removeFile fconfigure.dummy
|
| ︙ | ︙ | |||
354 355 356 357 358 359 360 361 362 |
test iocmd-10.4 {fblocked command} {
list [catch {fblocked stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-10.5 {fblocked command} {
fblocked stdin
} 0
removeFile test5
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
| > > > | | | | | | | | | | | | | | | | | | | | | | | 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 |
test iocmd-10.4 {fblocked command} {
list [catch {fblocked stdout} msg] $msg
} {1 {channel "stdout" wasn't opened for reading}}
test iocmd-10.5 {fblocked command} {
fblocked stdin
} 0
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
removeFile 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} {
removeFile 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} {
removeFile test3
set msg [list [catch {open $path(test3) RDONLY} msg] $msg]
regsub [file join {} $path(test3)] $msg "test3" msg
string tolower $msg
} {1 {couldn't open "test3": no such file or directory}}
test iocmd-12.3 {POSIX open access modes: WRONLY} {
removeFile test3
set msg [list [catch {open $path(test3) WRONLY} msg] $msg]
regsub [file join {} $path(test3)] $msg "test3" msg
string tolower $msg
} {1 {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} {
removeFile 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} {
removeFile test3
set msg [list [catch {open $path(test3) RDWR} msg] $msg]
regsub [file join {} $path(test3)] $msg "test3" msg
string tolower $msg
} {1 {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}}
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?"}}
test iocmd-13.3 {errors in open command} {
list [catch {open $path(test1) x} msg] $msg
} {1 {illegal access mode "x"}}
test iocmd-13.4 {errors in open command} {
list [catch {open $path(test1) rw} msg] $msg
} {1 {illegal access mode "rw"}}
test iocmd-13.5 {errors in open command} {
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}}}
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
} {0 0}
test iocmd-14.8 {file id parsing errors} {
list [catch {eof stderr} msg] $msg
} {0 0}
test iocmd-14.9 {file id parsing errors} {
list [catch {eof stderr1} msg] $msg
} {1 {can not find channel named "stderr1"}}
| > | > > > > | > | | > | 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 |
} {0 0}
test iocmd-14.8 {file id parsing errors} {
list [catch {eof stderr} msg] $msg
} {0 0}
test iocmd-14.9 {file id parsing errors} {
list [catch {eof stderr1} msg] $msg
} {1 {can not find channel named "stderr1"}}
set f [open $path(test1) w]
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} {
list [catch {fcopy} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.2 {Tcl_FcopyObjCmd} {
list [catch {fcopy 1} msg] $msg
} {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}}
test iocmd-15.3 {Tcl_FcopyObjCmd} {
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} {
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} {
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} {
list [catch {fcopy foo $wfile} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.7 {Tcl_FcopyObjCmd} {
list [catch {fcopy $rfile foo} msg] $msg
} {1 {can not find channel named "foo"}}
test iocmd-15.8 {Tcl_FcopyObjCmd} {
|
| ︙ | ︙ |
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 19 20 21 22 23 24 25 26 27 28 29 |
# 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.10.8.1 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::testConstraint testopenfilechannelproc \
[llength [info commands testopenfilechannelproc]]
::tcltest::testConstraint testaccessproc \
[llength [info commands testaccessproc]]
::tcltest::testConstraint teststatproc \
[llength [info commands teststatproc]]
set unsetScript {
catch {unset testStat1(size)}
catch {unset testStat2(size)}
catch {unset testStat3(size)}
}
|
| ︙ | ︙ | |||
49 50 51 52 53 54 55 |
file stat testStat3%.fil testStat3
list $testStat2(size) $testStat1(size) $testStat3(size)
} {2345 1234 3456}
eval $unsetScript
| | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
file stat testStat3%.fil testStat3
list $testStat2(size) $testStat1(size) $testStat3(size)
} {2345 1234 3456}
eval $unsetScript
test ioUtil-1.4 {TclStatDeleteProc: "TclpStat" function should not be deletable.} {teststatproc} {
catch {teststatproc delete TclpStat} err2
set err2
} {"TclpStat": could not be deleteed}
test ioUtil-1.5 {TclStatDeleteProc: Delete the 2nd TclStat procedure.} {teststatproc} {
# Delete the 2nd procedure and test that it longer exists but that
# the others do actually return a result.
|
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} {testaccessproc} {
list [file exists testAccess2%.fil] \
[file exists testAccess1%.fil] \
[file exists testAccess3%.fil]
} {1 1 1}
| | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 |
test ioUtil-2.3 {TclAccess: Use "file access ?" to invoke each procedure.} {testaccessproc} {
list [file exists testAccess2%.fil] \
[file exists testAccess1%.fil] \
[file exists testAccess3%.fil]
} {1 1 1}
test ioUtil-2.4 {TclAccessDeleteProc: "TclpAccess" function should not be deletable.} {testaccessproc} {
catch {testaccessproc delete TclpAccess} err2
set err2
} {"TclpAccess": could not be deleteed}
test ioUtil-2.5 {TclAccessDeleteProc: Delete the 2nd TclAccess procedure.} {testaccessproc} {
# Delete the 2nd procedure and test that it longer exists but that
# the others do actually return a result.
|
| ︙ | ︙ | |||
181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
catch {testaccessproc delete TestAccessProc1} err9
catch {testaccessproc delete TestAccessProc2} err10
catch {testaccessproc delete TestAccessProc3} err11
list $err9 $err10 $err11
} {{"TestAccessProc1": could not be deleteed} {"TestAccessProc2": could not be deleteed} {"TestAccessProc3": could not be deleteed}}
test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} {
catch {eval [list file delete -force] [glob *testOpenFileChannel*]}
catch {file exists testOpenFileChannel1%.fil} err1
catch {file exists testOpenFileChannel2%.fil} err2
catch {file exists testOpenFileChannel3%.fil} err3
catch {file exists __testOpenFileChannel1%__.fil} err4
| > > > > | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
catch {testaccessproc delete TestAccessProc1} err9
catch {testaccessproc delete TestAccessProc2} err10
catch {testaccessproc delete TestAccessProc3} err11
list $err9 $err10 $err11
} {{"TestAccessProc1": could not be deleteed} {"TestAccessProc2": could not be deleteed} {"TestAccessProc3": could not be deleteed}}
# Some of the following tests require a writable current directory
set oldpwd [pwd]
cd [temporaryDirectory]
test ioUtil-3.1 {TclOpenFileChannel: Check that none of the test procs are there.} {testopenfilechannelproc} {
catch {eval [list file delete -force] [glob *testOpenFileChannel*]}
catch {file exists testOpenFileChannel1%.fil} err1
catch {file exists testOpenFileChannel2%.fil} err2
catch {file exists testOpenFileChannel3%.fil} err3
catch {file exists __testOpenFileChannel1%__.fil} err4
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 |
file delete __testOpenFileChannel1%__.fil
file delete __testOpenFileChannel2%__.fil
file delete __testOpenFileChannel3%__.fil
set err
} {}
| | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
file delete __testOpenFileChannel1%__.fil
file delete __testOpenFileChannel2%__.fil
file delete __testOpenFileChannel3%__.fil
set err
} {}
test ioUtil-3.4 {TclOpenFileChannelDeleteProc: "TclpOpenFileChannel" function should not be deletable.} {testopenfilechannelproc} {
catch {testopenfilechannelproc delete TclpOpenFileChannel} err2
set err2
} {"TclpOpenFileChannel": could not be deleteed}
test ioUtil-3.5 {TclOpenFileChannelDeleteProc: Delete the 2nd TclOpenFileChannel procedure.} {testopenfilechannelproc} {
# Delete the 2nd procedure and test that it longer exists but that
# the others do actually return a result.
testopenfilechannelproc delete TestOpenFileChannelProc2
close [open __testOpenFileChannel1%__.fil w]
close [open __testOpenFileChannel3%__.fil w]
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 302 303 304 |
catch {testopenfilechannelproc delete TestOpenFileChannelProc1} err9
catch {testopenfilechannelproc delete TestOpenFileChannelProc2} err10
catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11
list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
# cleanup
::tcltest::cleanupTests
return
| > > < < < < < < < < < < < < | 299 300 301 302 303 304 305 306 307 308 309 310 |
catch {testopenfilechannelproc delete TestOpenFileChannelProc1} err9
catch {testopenfilechannelproc delete TestOpenFileChannelProc2} err10
catch {testopenfilechannelproc delete TestOpenFileChannelProc3} err11
list $err9 $err10 $err11
} {{"TestOpenFileChannelProc1": could not be deleteed} {"TestOpenFileChannelProc2": could not be deleteed} {"TestOpenFileChannelProc3": could not be deleteed}}
cd $oldpwd
# cleanup
::tcltest::cleanupTests
return
|
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 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: 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.2.14.3 2002/08/20 20:25:28 das 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 {
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::test
namespace import ::tcltest::testConstraint
testConstraint testchannel [llength [info commands testchannel]]
set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
} dummy]
# " capture coloring of quotes
set path(dummyout) [makeFile {} dummyout]
set path(__echo_srv__.tcl) [makeFile {
#!/usr/local/bin/tclsh
# -*- tcl -*-
# echo server
#
# arguments, options: port to listen on for connections.
# delay till echo of first block
# delay between blocks
|
| ︙ | ︙ | |||
128 129 130 131 132 133 134 |
}
#fileevent stdin readable {exit ;#cut}
# main
socket -server newconn $port
vwait forever
| | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
}
#fileevent stdin readable {exit ;#cut}
# main
socket -server newconn $port
vwait forever
} __echo_srv__.tcl]
########################################################################
proc fevent {fdelay idelay blocks script data} {
# start and initialize an echo server, prepare data
# transmission, then hand over to the test script.
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
array set a $alist
array_sget a
}
########################################################################
| < | | | | | 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 |
array set a $alist
array_sget a
}
########################################################################
test iogt-1.1 {stack/unstack} testchannel {
set fh [open $path(dummy) r]
identity -attach $fh
testchannel unstack $fh
close $fh
} {}
test iogt-1.2 {stack/close} testchannel {
set fh [open $path(dummy) r]
identity -attach $fh
close $fh
} {}
test iogt-1.3 {stack/unstack, configuration, options} testchannel {
set fh [open $path(dummy) r]
set ca [asort [fconfigure $fh]]
identity -attach $fh
set cb [asort [fconfigure $fh]]
testchannel unstack $fh
set cc [asort [fconfigure $fh]]
close $fh
# With this system none of the buffering, translation and
# encoding option may change their values with channels
# stacked upon each other or not.
# cb == ca == cc
list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc]
} {1 1 1}
test iogt-1.4 {stack/unstack, configuration} testchannel {
set fh [open $path(dummy) r]
set ca [asort [fconfigure $fh]]
identity -attach $fh
fconfigure $fh \
-buffering line \
-translation cr \
-encoding shiftjis
testchannel unstack $fh
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
]
close $fh
set res
} {0 line cr shiftjis}
test iogt-2.0 {basic I/O going through transform} testchannel {
| | | | | | | | 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 |
]
close $fh
set res
} {0 line cr shiftjis}
test iogt-2.0 {basic I/O going through transform} testchannel {
set fin [open $path(dummy) r]
set fout [open $path(dummyout) w]
identity -attach $fin
identity -attach $fout
fcopy $fin $fout
close $fin
close $fout
set fin [open $path(dummy) r]
set fout [open $path(dummyout) r]
set res [string equal [set in [read $fin]] [set out [read $fout]]]
lappend res [string length $in] [string length $out]
close $fin
close $fout
set res
} {1 71 71}
test iogt-2.1 {basic I/O, operation trail} {testchannel unixOnly} {
set fin [open $path(dummy) r]
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 5
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 |
write
write
write
flush/write
delete/write}
test iogt-2.2 {basic I/O, data trail} {testchannel unixOnly} {
| | | | 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
write
write
write
flush/write
delete/write}
test iogt-2.2 {basic I/O, data trail} {testchannel unixOnly} {
set fin [open $path(dummy) r]
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 5
|
| ︙ | ︙ | |||
591 592 593 594 595 596 597 |
} {
}
flush/write {} {}
delete/write {} *ignored*}
test iogt-2.3 {basic I/O, mixed trail} {testchannel unixOnly} {
| | | | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 |
} {
}
flush/write {} {}
delete/write {} *ignored*}
test iogt-2.3 {basic I/O, mixed trail} {testchannel unixOnly} {
set fin [open $path(dummy) r]
set fout [open $path(dummyout) w]
set trail [list]
audit_flow trail -attach $fin
audit_flow trail -attach $fout
fconfigure $fin -buffersize 20
fconfigure $fout -buffersize 10
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
# I was able to circumvent this by using the echo.tcl server with a big
# delay, causing the fcopy to underflow immediately.
proc DoneCopy {n {err {}}} {
variable copy ; set copy 1
}
| | | 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 |
# I was able to circumvent this by using the echo.tcl server with a big
# delay, causing the fcopy to underflow immediately.
proc DoneCopy {n {err {}}} {
variable copy ; set copy 1
}
set fin [open $path(dummy) r]
fevent 1000 500 {20 20 20 10 1 1} {
close $fin
set fout [open dummyout w]
flush $sock ; # now, or fcopy will error us out
|
| ︙ | ︙ | |||
679 680 681 682 683 684 685 |
close $fout
rename DoneCopy {}
# Check result of copy.
| | | | | 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 |
close $fout
rename DoneCopy {}
# Check result of copy.
set fin [open $path(dummy) r]
set fout [open $path(dummyout) r]
set res [string equal [read $fin] [read $fout]]
close $fin
close $fout
list $res $trail
} {1 {create/write create/read write flush/write flush/read delete/write delete/read}}
test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} {
set fin [open $path(dummy) r]
set data [read $fin]
close $fin
set trail [list]
set got [list]
proc Done {args} {
|
| ︙ | ︙ | |||
823 824 825 826 827 828 829 |
rblock | delete/read {} {} | {}
flush/write {} {}
delete/write {} *ignored*
delete/read {} *ignored*} ; # catch unescaped quote "
test iogt-5.0 {EOF simulation} {testchannel unknownFailure} {
| | | | 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 |
rblock | delete/read {} {} | {}
flush/write {} {}
delete/write {} *ignored*
delete/read {} *ignored*} ; # catch unescaped quote "
test iogt-5.0 {EOF simulation} {testchannel unknownFailure} {
set fin [open $path(dummy) r]
set fout [open $path(dummyout) w]
set trail [list]
audit_flow trail -attach $fin
stopafter_audit d trail 20 -attach $fin
audit_flow trail -attach $fout
|
| ︙ | ︙ | |||
902 903 904 905 906 907 908 |
}
proc constx {-attach channel} {
testchannel transform $channel -command [namespace code constX]
}
test iogt-6.0 {Push back} testchannel {
| | | | 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 |
}
proc constx {-attach channel} {
testchannel transform $channel -command [namespace code constX]
}
test iogt-6.0 {Push back} testchannel {
set f [open $path(dummy) r]
# contents of dummy = "abcdefghi..."
read $f 3 ; # skip behind "abc"
constx -attach $f
# expect to get "xxx" from the transform because
# of unread "def" input to transform which returns "xxx".
#
# Actually the IO layer pre-read the whole file and will
# read "def" directly from the buffer without bothering
# to consult the newly stacked transformation. This is
# wrong.
set res [read $f 3]
close $f
set res
} {xxx}
test iogt-6.1 {Push back and up} {testchannel knownBug} {
set f [open $path(dummy) r]
# contents of dummy = "abcdefghi..."
read $f 3 ; # skip behind "abc"
constx -attach $f
set res [read $f 3]
|
| ︙ | ︙ |
Changes to tests/link.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: none # # This file contains a collection of tests for Tcl_LinkVar and related # library procedures. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # # Copyright (c) 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 |
# Commands covered: none
#
# This file contains a collection of tests for Tcl_LinkVar and related
# library procedures. Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 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: link.test,v 1.5.18.2 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::testConstraint testlink \
[expr {[info commands testlink] != {}}]
foreach i {int real bool string} {
catch {unset $i}
}
test link-1.1 {reading C variables from Tcl} {testlink} {
testlink delete
|
| ︙ | ︙ |
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 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 |
# 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.7.18.2 2002/08/20 20:25:28 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
# platform.
if {$tcl_platform(platform) == "macintosh"} {
puts "can't run dynamic library tests on macintosh machines"
::tcltest::cleanupTests
return
}
# Tests require the existence of one of the DLLs in the dltest directory.
set ext [info sharedlibextension]
set testDir [file join [file dirname [info nameofexecutable]] dltest]
set x [file join $testDir pkga$ext]
set dll "[file tail $x]Required"
::tcltest::testConstraint $dll [file readable $x]
# Tests also require that this DLL has not already been loaded.
set loaded "[file tail $x]Loaded"
set alreadyLoaded [info loaded]
::tcltest::testConstraint $loaded \
[expr {![string match *pkga* $alreadyLoaded]}]
set alreadyTotalLoaded [info loaded]
test load-1.1 {basic errors} [list $dll $loaded] {
list [catch {load} msg] $msg
} {1 {wrong # args: should be "load fileName ?packageName? ?interp?"}}
|
| ︙ | ︙ |
Changes to tests/macFCmd.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) 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 |
# 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) 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: macFCmd.test,v 1.7.18.3 2002/08/20 20:25:28 das 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
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
catch {file delete -force foo.dir}
file mkdir foo.dir
if {[catch {file attributes foo.dir -readonly 1}]} {
set ::tcltest::testConstraints(fileSharing) 0
set ::tcltest::testConstraints(notFileSharing) 1
} else {
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 196 197 |
catch {file delete -force foo.dir}
file mkdir foo.dir
list [catch {file attributes foo.dir -readonly 1} msg] $msg \
[file delete -force foo.dir]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}
# cleanup
::tcltest::cleanupTests
return
| > < < < < < < < < < < < < | 194 195 196 197 198 199 200 201 202 203 |
catch {file delete -force foo.dir}
file mkdir foo.dir
list [catch {file attributes foo.dir -readonly 1} msg] $msg \
[file delete -force foo.dir]
} {1 {cannot set a directory to read-only when File Sharing is turned off} {}}
# cleanup
cd $oldcwd
::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 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
# This file contains a collection of tests for generic/tclMain.c.
#
# RCS: @(#) $Id: main.test,v 1.4.2.3 2002/08/20 20:25:28 das 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 {
namespace import ::tcltest::test
namespace import ::tcltest::testConstraint
namespace import ::tcltest::interpreter
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::temporaryDirectory
namespace import ::tcltest::workingDirectory
# Is [exec] defined?
testConstraint exec [llength [info commands exec]]
# Is the Tcltest package loaded?
# - that is, the special C-coded testing commands in tclTest.c
# - tests use testing commands introduced in Tcltest 8.4
|
| ︙ | ︙ | |||
36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
return
}
# Grrr... Behavior depends on this value.
after 1000
}
}
# Tests Tcl_Main-1.*: variable initializations
test Tcl_Main-1.1 {
Tcl_Main: startup script - normal
} -constraints {
stdio
} -setup {
| > | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
return
}
# Grrr... Behavior depends on this value.
after 1000
}
}
cd [temporaryDirectory]
# Tests Tcl_Main-1.*: variable initializations
test Tcl_Main-1.1 {
Tcl_Main: startup script - normal
} -constraints {
stdio
} -setup {
|
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 |
set tcl_interactive 1} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\nfoo\n"
cleanupTests
}
namespace delete ::tcl::test::main
return
| > > | 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 |
set tcl_interactive 1} >& result
set f [open result]
read $f
} -cleanup {
close $f
file delete result
} -result "1\nfoo\n"
cd [workingDirectory]
cleanupTests
}
namespace delete ::tcl::test::main
return
|
Changes to tests/msgcat.test.
|
| < < < < | > > > > | < | | > > < | < | | > | < < < | | > > > > | | > | > > > > > > > > | < > | | > > > > > > > > > | > > > > | > | > | | | > > > > > > > > > | > > > > | < < > > | > | > > | | < | > | | > | | | > | > | | > > > > > | > | | > > > > | | | > > | > > > | | > | > > > > > | | | > > > > > | | | > > > > > > | | > | > > > > > | | < | < | < | | | > | | | > | > > > > | | > > > > > > | | | | < | > | > > > | | > | > | | | > > > > > > > > > | | | | | | > > > > > > > | | > > > | > > > | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > | > > > > | | | | | | | < | < | < | < | < < < < < < < < < | < < < | | > > > | | | | | > > | < | < | > | | | | > > | < | < | < | < < | > | | | | < | < < < < | < | > > | > | | > | | | < < < | | | | | > > | < > > | | > > | | | | | | | > > | < > > | | > | | | | < < | > > | < | | < < | | < > > > | > > > | | < > | < > > | > > > | > | < < | | | | | < | > | | | < | < | < < < < | < | < | < | < < | > | | > | > > > | > | | > > > | > > | | | | | | | > | < > > | | > | | | | | | < | > | > > > > > > > > > > > > > | | | | < | | | < | | | < | | < > | | < < | < > | | < | > | > > | | | < | > | | | < | < < | | | | | | | | | | > | < | > | | < > > > > > > | > > > > > > > | | | | < | | < < < < < > | < | | | < | | > | 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 |
# This file contains a collection of tests for the msgcat package.
# Sourcing this file into Tcl runs the tests and
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1998 Mark Harrison.
# Copyright (c) 1998-1999 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.
#
# 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.10.14.1 2002/08/20 20:25:28 das 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}]} {
puts stderr "Skipping tests in [info script]. No msgcat 1.3 found to test."
return
}
namespace eval ::msgcat::test {
namespace import ::msgcat::*
namespace import ::tcltest::test
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::temporaryDirectory
namespace import ::tcltest::make*
namespace import ::tcltest::remove*
# Tests msgcat-0.*: locale initialization
proc PowerSet {l} {
if {[llength $l] == 0} {return [list [list]]}
set element [lindex $l 0]
set rest [lrange $l 1 end]
set result [list]
foreach x [PowerSet $rest] {
lappend result [linsert $x 0 $element]
lappend result $x
}
return $result
}
variable envVars {LC_ALL LC_MESSAGES LANG}
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} {
set result c
}
test msgcat-0.$count {
locale initialization from environment variables
} -setup {
variable var
foreach var $envVars {
catch {variable $var $::env($var)}
catch {unset ::env($var)}
}
foreach var $setVars {
set ::env($var) $var
}
interp create [namespace current]::i
i eval [list package ifneeded msgcat [package provide msgcat] \
[package ifneeded msgcat [package provide msgcat]]]
i eval package require msgcat
} -cleanup {
interp delete [namespace current]::i
foreach var $envVars {
catch {unset ::env($var)}
catch {set ::env($var) [set [namespace current]::$var]}
}
} -body {i eval msgcat::mclocale} -result $result
incr count
}
catch {unset result}
# Could add tests of initialization from Windows registry here.
# Use a fake registry package.
# Tests msgcat-1.*: [mclocale], [mcpreferences]
test msgcat-1.3 {mclocale set, single element} -setup {
variable locale [mclocale]
} -cleanup {
mclocale $locale
} -body {
mclocale en
} -result en
test msgcat-1.4 {mclocale get, single element} -setup {
variable locale [mclocale]
mclocale en
} -cleanup {
mclocale $locale
} -body {
mclocale
} -result en
test msgcat-1.5 {mcpreferences, single element} -setup {
variable locale [mclocale]
mclocale en
} -cleanup {
mclocale $locale
} -body {
mcpreferences
} -result en
test msgcat-1.6 {mclocale set, two elements} -setup {
variable locale [mclocale]
} -cleanup {
mclocale $locale
} -body {
mclocale en_US
} -result en_us
test msgcat-1.7 {mclocale get, two elements} -setup {
variable locale [mclocale]
mclocale en_US
} -cleanup {
mclocale $locale
} -body {
mclocale
} -result en_us
test msgcat-1.8 {mcpreferences, two elements} -setup {
variable locale [mclocale]
mclocale en_US
} -cleanup {
mclocale $locale
} -body {
mcpreferences
} -result {en_us en}
test msgcat-1.9 {mclocale set, three elements} -setup {
variable locale [mclocale]
} -cleanup {
mclocale $locale
} -body {
mclocale en_US_funky
} -result en_us_funky
test msgcat-1.10 {mclocale get, three elements} -setup {
variable locale [mclocale]
mclocale en_US_funky
} -cleanup {
mclocale $locale
} -body {
mclocale
} -result en_us_funky
test msgcat-1.11 {mcpreferences, three elements} -setup {
variable locale [mclocale]
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}
test msgcat-2.2 {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]
mclocale foo_BAR
} -cleanup {
mclocale $locale
} -body {
namespace eval bar {::msgcat::mc con1}
} -result con1bar
test msgcat-2.4 {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]
mclocale foo_BAR
} -cleanup {
mclocale $locale
} -body {
namespace eval baz {::msgcat::mc con1}
} -result con1baz
test msgcat-2.5 {mcmset, global scope} -setup {
namespace eval :: {
::msgcat::mcmset foo_BAR {
src1 trans1
src2 trans2
}
}
variable locale [mclocale]
mclocale foo_BAR
} -cleanup {
mclocale $locale
} -body {
namespace eval :: {
::msgcat::mc src1
}
} -result trans1
test msgcat-2.6 {mcmset, namespace overlap} -setup {
namespace eval bar {::msgcat::mcmset foo_BAR {con2 con2bar}}
namespace eval baz {::msgcat::mcmset foo_BAR {con2 con2baz}}
variable locale [mclocale]
mclocale foo_BAR
} -cleanup {
mclocale $locale
} -body {
namespace eval bar {::msgcat::mc con2}
} -result con2bar
test msgcat-2.7 {mcmset, namespace overlap} -setup {
namespace eval bar {::msgcat::mcmset foo_BAR {con2 con2bar}}
namespace eval baz {::msgcat::mcmset foo_BAR {con2 con2baz}}
variable locale [mclocale]
mclocale foo_BAR
} -cleanup {
mclocale $locale
} -body {
namespace eval baz {::msgcat::mc con2}
} -result con2baz
# Tests msgcat-3.*: [mcset], [mc], catalog "inheritance"
#
# Test mcset and mc, ensuring that more specific locales
# (e.g. en_UK) will search less specific locales
# (e.g. en) for translation strings.
#
# Do this for the 12 permutations of
# locales: {foo foo_BAR foo_BAR_baz}
# strings: {ov1 ov2 ov3 ov4}
# locale foo defines ov1, ov2, ov3
# locale foo_BAR defines ov2, ov3
# locale foo_BAR_BAZ defines ov3
# (ov4 is defined in none)
# So,
# ov3 should be resolved in foo, foo_BAR, foo_BAR_baz
# ov2 should be resolved in foo, foo_BAR
# ov2 should resolve to foo_BAR in foo_BAR_baz
# ov1 should be resolved in foo
# ov1 should resolve to foo in foo_BAR, foo_BAR_baz
# ov4 should be resolved in none, and call mcunknown
#
variable count 2
variable result
array set result {
foo,ov1 ov1_foo foo,ov2 ov2_foo foo,ov3 ov3_foo foo,ov4 ov4
foo_BAR,ov1 ov1_foo foo_BAR,ov2 ov2_foo_BAR foo_BAR,ov3 ov3_foo_BAR
foo_BAR,ov4 ov4 foo_BAR_baz,ov1 ov1_foo foo_BAR_baz,ov2 ov2_foo_BAR
foo_BAR_baz,ov3 ov3_foo_BAR_baz foo_BAR_baz,ov4 ov4
}
variable loc
variable string
foreach loc {foo foo_BAR foo_BAR_baz} {
foreach string {ov1 ov2 ov3 ov4} {
test msgcat-3.$count {mcset, overlap} -setup {
mcset foo ov1 ov1_foo
mcset foo ov2 ov2_foo
mcset foo ov3 ov3_foo
mcset foo_BAR ov2 ov2_foo_BAR
mcset foo_BAR ov3 ov3_foo_BAR
mcset foo_BAR_baz ov3 ov3_foo_BAR_baz
variable locale [mclocale]
mclocale $loc
} -cleanup {
mclocale $locale
} -body {
mc $string
} -result $result($loc,$string)
incr count
}
}
catch {unset result}
# Tests msgcat-4.*: [mcunknown]
test msgcat-4.2 {mcunknown, default} -setup {
mcset foo unk1 "unknown 1"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc unk1
} -result {unknown 1}
test msgcat-4.3 {mcunknown, default} -setup {
mcset foo unk1 "unknown 1"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc unk2
} -result unk2
test msgcat-4.4 {mcunknown, overridden} -setup {
rename ::msgcat::mcunknown SavedMcunknown
proc ::msgcat::mcunknown {dom s} {
return unknown:$dom:$s
}
mcset foo unk1 "unknown 1"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
rename ::msgcat::mcunknown {}
rename SavedMcunknown ::msgcat::mcunknown
} -body {
mc unk1
} -result {unknown 1}
test msgcat-4.5 {mcunknown, overridden} -setup {
rename ::msgcat::mcunknown SavedMcunknown
proc ::msgcat::mcunknown {dom s} {
return unknown:$dom:$s
}
mcset foo unk1 "unknown 1"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
rename ::msgcat::mcunknown {}
rename SavedMcunknown ::msgcat::mcunknown
} -body {
mc unk2
} -result {unknown:foo:unk2}
test msgcat-4.6 {mcunknown, uplevel context} -setup {
rename ::msgcat::mcunknown SavedMcunknown
proc ::msgcat::mcunknown {dom s} {
return "unknown:$dom:$s:[expr {[info level] - 1}]"
}
mcset foo unk1 "unknown 1"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
rename ::msgcat::mcunknown {}
rename SavedMcunknown ::msgcat::mcunknown
} -body {
mc unk2
} -result unknown:foo:unk2:[info level]
# Tests msgcat-5.*: [mcload]
variable locales {foo foo_BAR foo_BAR_baz}
makeDirectory msgdir
foreach loc $locales {
makeFile "::msgcat::mcset $loc abc abc-$loc" \
[string tolower [file join msgdir $loc.msg]]
}
variable count 1
foreach loc {foo foo_BAR foo_BAR_baz} {
test msgcat-5.$count {mcload} -setup {
variable locale [mclocale]
mclocale $loc
} -cleanup {
mclocale $locale
} -body {
mcload [file join [temporaryDirectory] msgdir]
} -result $count
incr count
}
# Even though foo_BAR_notexist does not exist,
# foo_BAR and foo should be loaded.
test msgcat-5.4 {mcload} -setup {
variable locale [mclocale]
mclocale foo_BAR_notexist
} -cleanup {
mclocale $locale
} -body {
mcload [file join [temporaryDirectory] msgdir]
} -result 2
test msgcat-5.5 {mcload} -setup {
variable locale [mclocale]
mclocale no_FI_notexist
} -cleanup {
mclocale $locale
} -body {
mcload [file join [temporaryDirectory] msgdir]
} -result 0
test msgcat-5.6 {mcload} -setup {
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc abc
} -result abc-foo
test msgcat-5.7 {mcload} -setup {
variable locale [mclocale]
mclocale foo_BAR
} -cleanup {
mclocale $locale
} -body {
mc abc
} -result abc-foo_BAR
test msgcat-5.8 {mcload} -setup {
variable locale [mclocale]
mclocale foo_BAR_baz
} -cleanup {
mclocale $locale
} -body {
mc abc
} -result abc-foo_BAR_baz
test msgcat-5.9 {mcload} -setup {
rename ::msgcat::mcunknown SavedMcunknown
proc ::msgcat::mcunknown {dom s} {
return unknown:$dom:$s
}
variable locale [mclocale]
mclocale no_FI_notexist
} -cleanup {
mclocale $locale
rename ::msgcat::mcunknown {}
rename SavedMcunknown ::msgcat::mcunknown
} -body {
mc abc
} -result unknown:no_fi_notexist:abc
foreach loc $locales {
removeFile [string tolower [file join msgdir $loc.msg]]
}
removeDirectory msgdir
# Tests msgcat-6.*: [mcset], [mc] namespace inheritance
#
# Test mcset and mc, ensuring that resolution for messages
# proceeds from the current ns to its parent and so on to the
# global ns.
#
# Do this for the 12 permutations of
# locales: foo
# namespaces: foo foo::bar foo::bar::baz
# strings: {ov1 ov2 ov3 ov4}
# namespace ::foo defines ov1, ov2, ov3
# namespace ::foo::bar defines ov2, ov3
# namespace ::foo::bar::baz defines ov3
#
# ov4 is not defined in any namespace.
#
# So,
# ov3 should be resolved in ::foo::bar::baz, ::foo::bar, ::foo;
# ov2 should be resolved in ::foo, ::foo::bar
# ov1 should be resolved in ::foo
# ov4 should be resolved in none, and call mcunknown
#
variable result
array set result {
foo,ov1 ov1_foo foo,ov2 ov2_foo foo,ov3 ov3_foo foo,ov4 ov4
foo::bar,ov1 ov1_foo foo::bar,ov2 ov2_foo_bar
foo::bar,ov3 ov3_foo_bar foo::bar,ov4 ov4 foo::bar::baz,ov1 ov1_foo
foo::bar::baz,ov2 ov2_foo_bar foo::bar::baz,ov3 ov3_foo_bar_baz
foo::bar::baz,ov4 ov4
}
variable count 1
variable ns
foreach ns {foo foo::bar foo::bar::baz} {
foreach string {ov1 ov2 ov3 ov4} {
test msgcat-6.$count {mcset, overlap} -setup {
namespace eval foo {
::msgcat::mcset foo ov1 ov1_foo
::msgcat::mcset foo ov2 ov2_foo
::msgcat::mcset foo ov3 ov3_foo
namespace eval bar {
::msgcat::mcset foo ov2 ov2_foo_bar
::msgcat::mcset foo ov3 ov3_foo_bar
namespace eval baz {
::msgcat::mcset foo ov3 "ov3_foo_bar_baz"
}
}
}
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
namespace delete foo
} -body {
namespace eval $ns [list ::msgcat::mc $string]
} -result $result($ns,$string)
incr count
}
}
# Tests msgcat-7.*: [mc] extra args processed by [format]
test msgcat-7.1 {mc extra args go through to format} -setup {
mcset foo format1 "this is a test"
mcset foo format2 "this is a %s"
mcset foo format3 "this is a %s %s"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc format1 "good test"
} -result "this is a test"
test msgcat-7.2 {mc extra args go through to format} -setup {
mcset foo format1 "this is a test"
mcset foo format2 "this is a %s"
mcset foo format3 "this is a %s %s"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc format2 "good test"
} -result "this is a good test"
test msgcat-7.3 {mc errors from format are propagated} -setup {
mcset foo format1 "this is a test"
mcset foo format2 "this is a %s"
mcset foo format3 "this is a %s %s"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
catch {mc format3 "good test"}
} -result 1
test msgcat-7.4 {mc, extra args are given to unknown} -setup {
mcset foo format1 "this is a test"
mcset foo format2 "this is a %s"
mcset foo format3 "this is a %s %s"
variable locale [mclocale]
mclocale foo
} -cleanup {
mclocale $locale
} -body {
mc "this is a %s" "good test"
} -result "this is a good test"
cleanupTests
}
namespace delete ::msgcat::test
return
|
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 22 23 24 |
# 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.17.4.2 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
catch {eval namespace delete [namespace children :: test_ns_*]}
test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
|
| ︙ | ︙ | |||
1163 1164 1165 1166 1167 1168 1169 |
}
ns::a 1
set res [ns::a 2]
namespace delete ns
set res
} {New proc is called}
| | | 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 |
}
ns::a 1
set res [ns::a 2]
namespace delete ns
set res
} {New proc is called}
test namespace-41.3 {Shadowing byte-compiled commands, Bug: 231259} {knownBug} {
set res {}
namespace eval ns {
variable b 0
}
proc ns::a {i} {
variable b
|
| ︙ | ︙ |
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 |
# 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.5.18.2 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# Note that the Tcl expression parser (tclParseExpr.c) does not check
|
| ︙ | ︙ | |||
505 506 507 508 509 510 511 |
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-16.4 {GetLexeme procedure, integer lexeme} {
testexprparser {000} -1
} {- {} 0 subexpr 000 1 text 000 0 {}}
test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {wideIntegerUnparsed} {
list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
| > | | | > | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 |
} {- {} 0 subexpr 123 1 text 123 0 {}}
test parseExpr-16.4 {GetLexeme procedure, integer lexeme} {
testexprparser {000} -1
} {- {} 0 subexpr 000 1 text 000 0 {}}
test parseExpr-16.5 {GetLexeme procedure, integer lexeme too big} {wideIntegerUnparsed} {
list [catch {testexprparser {12345678901234567890} -1} msg] $msg
} {1 {integer value too large to represent}}
test parseExpr-16.6 {GetLexeme procedure, bad integer lexeme} -body {
testexprparser {0999} -1
} -returnCodes error -match glob -result {*invalid octal number*}
test parseExpr-16.7 {GetLexeme procedure, double lexeme} {
testexprparser {0.999} -1
} {- {} 0 subexpr 0.999 1 text 0.999 0 {}}
test parseExpr-16.8 {GetLexeme procedure, double lexeme} {
testexprparser {.123} -1
} {- {} 0 subexpr .123 1 text .123 0 {}}
test parseExpr-16.9 {GetLexeme procedure, double lexeme} {nonPortable unixOnly} {
|
| ︙ | ︙ |
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 24 25 26 27 28 29 30 31 32 33 34 |
# 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.10.8.1 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
tcltest::testConstraint testwordend \
[string equal "testwordend" [info commands testwordend]]
# Save the argv value for restoration later
set savedArgv $argv
proc fourArgs {a b c d} {
global arg1 arg2 arg3 arg4
set arg1 $a
set arg2 $b
set arg3 $c
set arg4 $d
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
info complete "xyz \[abc"
} {0}
# cleanup
::tcltest::cleanupTests
return
| > | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
info complete "xyz \[abc \{abc\]"
} {0}
test parseOld-15.5 {TclScriptEnd procedure} {
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 |
# 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.6.18.1 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
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
}
catch {removeFile test1}
set path(test1) [makeFile {} test1]
test pid-1.1 {pid command} {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} {unixOrPc unixExecs} {
set f [open [format {| echo foo | cat >%s} $path(test1)] w]
set pids [pid $f]
close $f
catch {removeFile test1}
list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
[regexp {^[0-9]+$} [lindex $pids 1]] \
[expr {[lindex $pids 0] == [lindex $pids 1]}]
} {2 1 1 0}
test pid-1.3 {pid command} {
set f [open $path(test1) w]
set pids [pid $f]
close $f
set pids
} {}
test pid-1.4 {pid command} {
list [catch {pid a b} msg] $msg
} {1 {wrong # args: should be "pid ?channelId?"}}
|
| ︙ | ︙ |
Deleted tests/pkg/circ1.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/circ2.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/circ3.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/global.tcl.
|
| < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/import.tcl.
|
| < < < < < < < < < < < < < < < < |
Deleted tests/pkg/magicchar.tcl.
|
| < < < < < < |
Deleted tests/pkg/magicchar2.tcl.
|
| < |
Deleted tests/pkg/pkg1.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/pkg2_a.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/pkg2_b.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/pkg3.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/pkg4.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/pkg5.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/pkga.tcl.
|
| < < < < < < < < < < < < < < < |
Deleted tests/pkg/samename.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/simple.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg/spacename.tcl.
|
| < < < |
Deleted tests/pkg/std.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg1/direct1.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < |
Deleted tests/pkg1/pkgIndex.tcl.
|
| < < < < < < < < < < < |
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 19 20 21 22 23 24 25 26 |
# 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.18.14.2 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
set fullPkgPath [makeDirectory pkg]
namespace eval pkgtest {
# Namespace for procs we can discard
}
# pkgtest::parseArgs --
#
|
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
proc pkgtest::createIndex { args } {
set parsed [eval parseArgs $args]
set options [lindex $parsed 0]
set dirPath [lindex $parsed 1]
set patternList [lindex $parsed 2]
file mkdir $dirPath
| | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 |
proc pkgtest::createIndex { args } {
set parsed [eval parseArgs $args]
set options [lindex $parsed 0]
set dirPath [lindex $parsed 1]
set patternList [lindex $parsed 2]
file mkdir $dirPath
if {[catch {
file delete [file join $dirPath pkgIndex.tcl]
eval pkg_mkIndex $options [list $dirPath] $patternList
} err]} {
return [list 1 $err]
}
|
| ︙ | ︙ | |||
233 234 235 236 237 238 239 | # Results: # Returns a two element list: # 0: 1 if the procedure encountered an error, 0 otherwise. # 1: if no error, this is the parsed generated index file, in the format # returned by pkgtest::parseIndex. # If error, this is the error result. | | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > > > > > > > > > > | > > > | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > > > | > > > > > > > > > | | > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# Results:
# Returns a two element list:
# 0: 1 if the procedure encountered an error, 0 otherwise.
# 1: if no error, this is the parsed generated index file, in the format
# returned by pkgtest::parseIndex.
# If error, this is the error result.
proc pkgtest::runCreatedIndex {rv args} {
if {[lindex $rv 0] == 0} {
set parsed [eval parseArgs $args]
set dirPath [lindex $parsed 1]
set idxFile [file join $dirPath pkgIndex.tcl]
if {[catch {
set result [list 0 [makePkgList [parseIndex $idxFile]]]
} err]} {
set result [list 1 $err]
}
file delete $idxFile
} else {
set result $rv
}
return $result
}
proc pkgtest::runIndex { args } {
set rv [eval createIndex $args]
return [eval [list runCreatedIndex $rv] $args]
}
# If there is no match to the patterns, make sure the directory hasn't
# changed on us
test pkgMkIndex-1.1 {nothing matches pattern - current dir is the same} {
list [pkgtest::runIndex -lazy $fullPkgPath nomatch.tcl] [pwd]
} [list {1 {no files matched glob pattern "nomatch.tcl"}} [pwd]]
makeFile {
# This is a simple package, just to check basic functionality.
package provide simple 1.0
namespace eval simple {
namespace export lower upper
}
proc simple::lower { stg } {
return [string tolower $stg]
}
proc simple::upper { stg } {
return [string toupper $stg]
}
} [file join pkg simple.tcl]
test pkgMkIndex-2.1 {simple package} {
pkgtest::runIndex -lazy $fullPkgPath simple.tcl
} {0 {{simple:1.0 {tclPkgSetup {simple.tcl source {::simple::lower ::simple::upper}}}}}}
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 } {
return [string tolower $stg]
}
proc global_upper { stg } {
return [string toupper $stg]
}
} [file join pkg global.tcl]
test pkgMkIndex-3.1 {simple package with global symbols} {
pkgtest::runIndex -lazy $fullPkgPath global.tcl
} {0 {{global:1.0 {tclPkgSetup {global.tcl source {global_lower global_upper}}}}}}
removeFile [file join pkg global.tcl]
makeFile {
# This package is required by pkg1.
# This package is split into two files, to test packages that are split
# over multiple files.
package provide pkg2 1.0
namespace eval pkg2 {
namespace export p2-1
}
proc pkg2::p2-1 { num } {
return [expr $num * 2]
}
} [file join pkg pkg2_a.tcl]
makeFile {
# This package is required by pkg1.
# This package is split into two files, to test packages that are split
# over multiple files.
package provide pkg2 1.0
namespace eval pkg2 {
namespace export p2-2
}
proc pkg2::p2-2 { num } {
return [expr $num * 3]
}
} [file join pkg pkg2_b.tcl]
test pkgMkIndex-4.1 {split package} {
pkgtest::runIndex -lazy $fullPkgPath pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}}}}
test pkgMkIndex-4.2 {split package - direct loading} {
pkgtest::runIndex -direct $fullPkgPath pkg2_a.tcl pkg2_b.tcl
} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
[list source [file join $fullPkgPath pkg2_b.tcl]]}}}"
# Add the direct1 directory to auto_path, so that the direct1 package
# can be found.
set direct1 [makeDirectory direct1]
lappend auto_path $direct1
makeFile {
# This is referenced by pkgIndex.tcl as a -direct script.
package provide direct1 1.0
namespace eval direct1 {
namespace export pd1 pd2
}
proc direct1::pd1 { stg } {
return [string tolower $stg]
}
proc direct1::pd2 { stg } {
return [string toupper $stg]
}
} [file join direct1 direct1.tcl]
pkg_mkIndex -direct $direct1 direct1.tcl
makeFile {
# Does a package require of direct1, whose pkgIndex.tcl entry
# is created above with option -direct. This tests that pkg_mkIndex
# can handle code that is sourced in pkgIndex.tcl files.
package require direct1
package provide std 1.0
namespace eval std {
namespace export p1 p2
}
proc std::p1 { stg } {
return [string tolower $stg]
}
proc std::p2 { stg } {
return [string toupper $stg]
}
} [file join pkg std.tcl]
test pkgMkIndex-5.1 {requires -direct package} {
pkgtest::runIndex -lazy $fullPkgPath std.tcl
} {0 {{std:1.0 {tclPkgSetup {std.tcl source {::std::p1 ::std::p2}}}}}}
removeFile [file join direct1 direct1.tcl]
file delete [file join $direct1 pkgIndex.tcl]
removeDirectory direct1
removeFile [file join pkg std.tcl]
makeFile {
# This package requires pkg3, but it does
# not use any of pkg3's procs in the code that is executed by the file
# (i.e. references to pkg3's procs are in the proc bodies only).
package require pkg3 1.0
package provide pkg1 1.0
namespace eval pkg1 {
namespace export p1-1 p1-2
}
proc pkg1::p1-1 { num } {
return [pkg3::p3-1 $num]
}
proc pkg1::p1-2 { num } {
return [pkg3::p3-2 $num]
}
} [file join pkg pkg1.tcl]
makeFile {
package provide pkg3 1.0
namespace eval pkg3 {
namespace export p3-1 p3-2
}
proc pkg3::p3-1 { num } {
return {[expr $num * 2]}
}
proc pkg3::p3-2 { num } {
return {[expr $num * 3]}
}
} [file join pkg pkg3.tcl]
test pkgMkIndex-6.1 {pkg1 requires pkg3} {
pkgtest::runIndex -lazy $fullPkgPath pkg1.tcl pkg3.tcl
} {0 {{pkg1:1.0 {tclPkgSetup {pkg1.tcl source {::pkg1::p1-1 ::pkg1::p1-2}}}} {pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}}}}
test pkgMkIndex-6.2 {pkg1 requires pkg3 - use -direct} {
pkgtest::runIndex -direct $fullPkgPath pkg1.tcl pkg3.tcl
} "0 {{pkg1:1.0 {[list source [file join $fullPkgPath pkg1.tcl]]}} {pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}}}"
removeFile [file join pkg pkg1.tcl]
makeFile {
# This package requires pkg3, and it calls
# a pkg3 proc in the code that is executed by the file
package require pkg3 1.0
package provide pkg4 1.0
namespace eval pkg4 {
namespace export p4-1 p4-2
variable m2 [pkg3::p3-1 10]
}
proc pkg4::p4-1 { num } {
variable m2
return [expr {$m2 * $num}]
}
proc pkg4::p4-2 { num } {
return [pkg3::p3-2 $num]
}
} [file join pkg pkg4.tcl]
test pkgMkIndex-7.1 {pkg4 uses pkg3} {
pkgtest::runIndex -lazy $fullPkgPath pkg4.tcl pkg3.tcl
} {0 {{pkg3:1.0 {tclPkgSetup {pkg3.tcl source {::pkg3::p3-1 ::pkg3::p3-2}}}} {pkg4:1.0 {tclPkgSetup {pkg4.tcl source {::pkg4::p4-1 ::pkg4::p4-2}}}}}}
test pkgMkIndex-7.2 {pkg4 uses pkg3 - use -direct} {
pkgtest::runIndex -direct $fullPkgPath pkg4.tcl pkg3.tcl
} "0 {{pkg3:1.0 {[list source [file join $fullPkgPath pkg3.tcl]]}} {pkg4:1.0 {[list source [file join $fullPkgPath pkg4.tcl]]}}}"
removeFile [file join pkg pkg4.tcl]
removeFile [file join pkg pkg3.tcl]
makeFile {
# This package requires pkg2, and it calls
# a pkg2 proc in the code that is executed by the file.
# Pkg2 is a split package.
package require pkg2 1.0
package provide pkg5 1.0
namespace eval pkg5 {
namespace export p5-1 p5-2
variable m2 [pkg2::p2-1 10]
variable m3 [pkg2::p2-2 10]
}
proc pkg5::p5-1 { num } {
variable m2
return [expr {$m2 * $num}]
}
proc pkg5::p5-2 { num } {
variable m2
return [expr {$m2 * $num}]
}
} [file join pkg pkg5.tcl]
test pkgMkIndex-8.1 {pkg5 uses pkg2} {
pkgtest::runIndex -lazy $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} {0 {{pkg2:1.0 {tclPkgSetup {pkg2_a.tcl source ::pkg2::p2-1} {pkg2_b.tcl source ::pkg2::p2-2}}} {pkg5:1.0 {tclPkgSetup {pkg5.tcl source {::pkg5::p5-1 ::pkg5::p5-2}}}}}}
test pkgMkIndex-8.2 {pkg5 uses pkg2 - use -direct} {
pkgtest::runIndex -direct $fullPkgPath pkg5.tcl pkg2_a.tcl pkg2_b.tcl
} "0 {{pkg2:1.0 {[list source [file join $fullPkgPath pkg2_a.tcl]]
[list source [file join $fullPkgPath pkg2_b.tcl]]}} {pkg5:1.0 {[list source [file join $fullPkgPath pkg5.tcl]]}}}"
removeFile [file join pkg pkg5.tcl]
removeFile [file join pkg pkg2_a.tcl]
removeFile [file join pkg pkg2_b.tcl]
makeFile {
# This package requires circ2, and circ2
# requires circ3, which in turn requires circ1.
# In case of cirularities, pkg_mkIndex should give up when it gets stuck.
package require circ2 1.0
package provide circ1 1.0
namespace eval circ1 {
namespace export c1-1 c1-2 c1-3 c1-4
}
proc circ1::c1-1 { num } {
return [circ2::c2-1 $num]
}
proc circ1::c1-2 { num } {
return [circ2::c2-2 $num]
}
proc circ1::c1-3 {} {
return 10
}
proc circ1::c1-4 {} {
return 20
}
} [file join pkg circ1.tcl]
makeFile {
# This package is required by circ1, and
# requires circ3. Circ3, in turn, requires circ1 to give us a circularity.
package require circ3 1.0
package provide circ2 1.0
namespace eval circ2 {
namespace export c2-1 c2-2
}
proc circ2::c2-1 { num } {
return [expr $num * [circ3::c3-1]]
}
proc circ2::c2-2 { num } {
return [expr $num * [circ3::c3-2]]
}
} [file join pkg circ2.tcl]
makeFile {
# This package is required by circ2, and in
# turn requires circ1. This closes the circularity.
package require circ1 1.0
package provide circ3 1.0
namespace eval circ3 {
namespace export c3-1 c3-4
}
proc circ3::c3-1 {} {
return [circ1::c1-3]
}
proc circ3::c3-2 {} {
return [circ1::c1-4]
}
} [file join pkg circ3.tcl]
test pkgMkIndex-9.1 {circular packages} {
pkgtest::runIndex -lazy $fullPkgPath circ1.tcl circ2.tcl circ3.tcl
} {0 {{circ1:1.0 {tclPkgSetup {circ1.tcl source {::circ1::c1-1 ::circ1::c1-2 ::circ1::c1-3 ::circ1::c1-4}}}} {circ2:1.0 {tclPkgSetup {circ2.tcl source {::circ2::c2-1 ::circ2::c2-2}}}} {circ3:1.0 {tclPkgSetup {circ3.tcl source ::circ3::c3-1}}}}}
removeFile [file join pkg circ1.tcl]
removeFile [file join pkg circ2.tcl]
removeFile [file join pkg circ3.tcl]
# Some tests require the existence of one of the DLLs in the dltest directory
set x [file join [file dirname [info nameofexecutable]] dltest \
pkga[info sharedlibextension]]
set dll "[file tail $x]Required"
::tcltest::testConstraint $dll [file exists $x]
if {[testConstraint $dll]} {
makeFile {
# This package provides Pkga, which is also provided by a DLL.
package provide Pkga 1.0
proc pkga_neq { x } {
return [expr {! [pkgq_eq $x]}]
}
} [file join pkg pkga.tcl]
file copy -force $x $fullPkgPath
}
testConstraint exec [llength [info commands ::exec]]
test pkgMkIndex-10.1 {package in DLL and script} [list exec $dll] {
# Do all [load]ing of shared libraries in another process, so
# we can delete the file and not get stuck because we're holding
# a reference to it.
set cmd [list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]
exec [interpreter] << $cmd
pkgtest::runCreatedIndex {0 {}} -lazy $fullPkgPath pkga[info sharedlibextension] pkga.tcl
} "0 {{Pkga:1.0 {tclPkgSetup {pkga[info sharedlibextension] load {pkga_eq pkga_quote}} {pkga.tcl source pkga_neq}}}}"
test pkgMkIndex-10.2 {package in DLL hidden by -load} [list exec $dll] {
# Do all [load]ing of shared libraries in another process, so
# we can delete the file and not get stuck because we're holding
# a reference to it.
#
# This test depends on context from prior test, so repeat it.
set script "[list pkg_mkIndex -lazy $fullPkgPath [file tail $x] pkga.tcl]\n"
append script \
"[list pkg_mkIndex -lazy -load Pkg* $fullPkgPath [file tail $x]]"
exec [interpreter] << $script
pkgtest::runCreatedIndex {0 {}} -lazy -load Pkg* -- $fullPkgPath pkga[info sharedlibextension]
} {0 {}}
if {[testConstraint $dll]} {
file delete -force [file join $fullPkgPath [file tail $x]]
removeFile [file join pkg pkga.tcl]
}
# Tolerate "namespace import" at the global scope
makeFile {
package provide fubar 1.0
namespace eval ::fubar:: {
#
# export only public functions.
#
namespace export {[a-z]*}
}
proc ::fubar::foo {bar} {
puts "$bar"
return true
}
namespace import ::fubar::foo
} [file join pkg import.tcl]
test pkgMkIndex-11.1 {conflicting namespace imports} {
pkgtest::runIndex -lazy $fullPkgPath import.tcl
} {0 {{fubar:1.0 {tclPkgSetup {import.tcl source ::fubar::foo}}}}}
removeFile [file join pkg import.tcl]
# Verify that the auto load list generated is correct even when there
# is a proc name conflict between two namespaces (ie, ::foo::baz and
# ::bar::baz)
makeFile {
package provide football 1.0
namespace eval ::pro:: {
#
# export only public functions.
#
namespace export {[a-z]*}
}
namespace eval ::college:: {
#
# export only public functions.
#
namespace export {[a-z]*}
}
proc ::pro::team {} {
puts "go packers!"
return true
}
proc ::college::team {} {
puts "go badgers!"
return true
}
} [file join pkg samename.tcl]
test pkgMkIndex-12.1 {same name procs in different namespace} {
pkgtest::runIndex -lazy $fullPkgPath samename.tcl
} {0 {{football:1.0 {tclPkgSetup {samename.tcl source {::college::team ::pro::team}}}}}}
removeFile [file join pkg samename.tcl]
# Proc names with embedded spaces are properly listed (ie, correct number of
# braces) in result
makeFile {
package provide spacename 1.0
proc {a b} {} {}
proc {c d} {} {}
} [file join pkg spacename.tcl]
test pkgMkIndex-13.1 {proc names with embedded spaces} {
pkgtest::runIndex -lazy $fullPkgPath spacename.tcl
} {0 {{spacename:1.0 {tclPkgSetup {spacename.tcl source {{a b} {c d}}}}}}}
removeFile [file join pkg spacename.tcl]
# Test the pkg_compareExtension helper function
test pkgMkIndex-14.1 {pkg_compareExtension} {unixOnly} {
pkg_compareExtension foo.so .so
} 1
test pkgMkIndex-14.2 {pkg_compareExtension} {unixOnly} {
pkg_compareExtension foo.so.bar .so
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 386 387 |
pkg_compareExtension foo .so
} 0
test pkgMkIndex-14.6 {pkg_compareExtension} {unixOnly} {
pkg_compareExtension foo.so.1.2.bar .so
} 0
# cleanup
namespace delete pkgtest
| > > < | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 |
pkg_compareExtension foo .so
} 0
test pkgMkIndex-14.6 {pkg_compareExtension} {unixOnly} {
pkg_compareExtension foo.so.1.2.bar .so
} 0
# cleanup
removeDirectory pkg
namespace delete pkgtest
::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 20 21 22 23 24 25 26 27 28 29 30 31 |
# 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.13.18.1 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# All tests require the testregexp command, return if this
# command doesn't exist
::tcltest::testConstraint testregexp \
[expr {[info commands testregexp] != {}}]
::tcltest::testConstraint localeRegexp 0
# This file uses some custom procedures, defined below, for regexp regression
# testing. The name of the procedure indicates the general nature of the
# test:
# e compile error expected
# f match failure expected
# m successful match
|
| ︙ | ︙ | |||
263 264 265 266 267 268 269 |
# The ! flag is used to indicate expected match failure (for REG_EXPECT,
# which wants argument testing even in the event of failure).
proc matchexpected {opts testid flags re target args} {
global prefix description ask regBug
if {[info exists regBug] && $regBug} {
# This will register as a skipped test
| | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
# The ! flag is used to indicate expected match failure (for REG_EXPECT,
# which wants argument testing even in the event of failure).
proc matchexpected {opts testid flags re target args} {
global prefix description ask regBug
if {[info exists regBug] && $regBug} {
# This will register as a skipped test
test $prefix.[tno $testid] [desc $testid] knownBug {format 0} {1}
return
}
# Tcl locale stuff doesn't do the ch/xy test fakery yet
if {[string first "+" $flags] >= 0} {
# This will register as a skipped test
test $prefix.[tno $testid] [desc $testid] localeRegexp {} {}
|
| ︙ | ︙ | |||
983 984 985 986 987 988 989 990 991 992 |
# back to normal stuff
m 9 HLP {(?n)^(?![t#])\S+} "tk\n\n#\n#\nit0" it0
# flush any leftover complaints
doing 0 "flush"
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > < < | 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 |
# back to normal stuff
m 9 HLP {(?n)^(?![t#])\S+} "tk\n\n#\n#\nit0" it0
# flush any leftover complaints
doing 0 "flush"
# 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
|
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 |
# 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.17.4.2 2002/08/20 20:25:28 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
catch {unset foo}
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
regexp .*d e
regexp .*e f
set x .
append x *a
regexp -nocase $x bbba
} 1
| < | | > > | < | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
regexp .*d e
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} {
exec
} {
exec [interpreter] [makeFile {puts [regexp {} foo]} junk.tcl]
} 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} {
|
| ︙ | ︙ |
Changes to tests/regexpComp.test.
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
regexp .*e f
set x .
append x *a
regexp -nocase $x bbba
}
} 1
| < | | > > | < | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 |
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} {
exec
} {
exec [interpreter] [makeFile {puts [regexp {} foo]} junk.tcl]
} 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} {
|
| ︙ | ︙ |
Changes to tests/result.test.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49
if {[lsearch [namespace children] ::tcltest] == -1} {
| | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# SCCS: @(#) result.test 1.4 97/12/08 15:07:49
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
# Some tests require the testsaveresult command
::tcltest::testConstraint testsaveresult \
[expr {[info commands testsaveresult] != {}}]
test result-1.1 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult append {set x 42} 0
|
| ︙ | ︙ |
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 22 23 24 25 26 27 28 |
# 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.11.14.2 2002/08/20 20:25:29 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::testConstraint 64bitInts [expr {0x80000000 > 0}]
test scan-1.1 {BuildCharSet, CharInSet} {
list [scan foo {%[^o]} x] $x
} {1 f}
test scan-1.2 {BuildCharSet, CharInSet} {
list [scan \]foo {%[]f]} x] $x
} {1 \]f}
|
| ︙ | ︙ |
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.14.14.1 2002/08/20 20:25:29 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc ignore args {}
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
list [lsort [array names aVaRnAmE]] [catch {set aVaRnAmE(e2)} msg] $msg
} {{e1 e2 e3} 0 v2}
test set-old-8.37.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.37.6 {array command, set with non-existent namespace} {
list [catch {array set bogusnamespace::var {a b}} msg] $msg
| | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 |
list [lsort [array names aVaRnAmE]] [catch {set aVaRnAmE(e2)} msg] $msg
} {{e1 e2 e3} 0 v2}
test set-old-8.37.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.37.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.37.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.38 {array command, size option} {
catch {unset a}
array size a
} {0}
|
| ︙ | ︙ |
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.20.2.3 2002/08/20 20:25:29 das 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 |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | # either in Tcl or in the environment; if they are, it attempts to connect to # the server. If the connection is successful, the tests using the remote # server will be performed; otherwise, it will attempt to start the remote # server (via exec) on platforms that support this, on the local host, # listening at port 2048. If all fails, a message is printed and the tests # using the remote server are not performed. | < | | | < < < | < | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 |
# either in Tcl or in the environment; if they are, it attempts to connect to
# the server. If the connection is successful, the tests using the remote
# server will be performed; otherwise, it will attempt to start the remote
# server (via exec) on platforms that support this, on the local host,
# listening at port 2048. If all fails, a message is printed and the tests
# using the remote server are not performed.
package require tcltest 2
namespace import -force ::tcltest::*
# Some tests require the testthread and exec commands
testConstraint testthread [llength [info commands testthread]]
testConstraint exec [llength [info commands exec]]
# If remoteServerIP or remoteServerPort are not set, check in the
# environment variables for externally set values.
#
if {![info exists remoteServerIP]} {
if {[info exists env(remoteServerIP)]} {
set remoteServerIP $env(remoteServerIP)
|
| ︙ | ︙ | |||
124 125 126 127 128 129 130 |
} else {
set remoteServerIP 127.0.0.1
# Be *extra* careful in case this file is sourced from
# a directory other than the current one...
set remoteFile [file join [pwd] [file dirname [info script]] \
remote.tcl]
if {[catch {set remoteProcChan \
| | | | 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 |
} else {
set remoteServerIP 127.0.0.1
# Be *extra* careful in case this file is sourced from
# a directory other than the current one...
set remoteFile [file join [pwd] [file dirname [info script]] \
remote.tcl]
if {[catch {set remoteProcChan \
[open "|[list [interpreter] $remoteFile \
-serverIsSilent \
-port $remoteServerPort \
-address $remoteServerIP]" \
w+]} \
msg] == 0} {
after 1000
if {[catch {set commandSocket [socket $remoteServerIP \
$remoteServerPort]} msg] == 0} {
fconfigure $commandSocket -translation crlf -buffering line
} else {
set noRemoteTestReason $msg
set doTestsWithRemoteServer 0
}
} else {
set noRemoteTestReason "$msg [interpreter]"
set doTestsWithRemoteServer 0
}
}
} else {
fconfigure $commandSocket -translation crlf -buffering line
}
}
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 250 251 252 |
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-2.1 {tcp connection} {socket stdio} {
removeFile script
| > > | | | | | | | | | | | | | 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 |
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} {
removeFile 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
close $file
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
puts $x
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
if {[catch {socket 127.0.0.1 $listen} msg]} {
set x $msg
} else {
lappend x [gets $f]
close $msg
}
lappend x [gets $f]
close $f
set x
} {ready done {}}
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} {
removeFile 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"
close $file
set x done
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
global port
if {[catch {socket -myport $port 127.0.0.1 $listen} sock]} {
set x $sock
close [socket 127.0.0.1 $listen]
puts stderr $sock
} else {
puts $sock hello
flush $sock
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} {
removeFile 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"
close $file
set x done
}
puts ready
vwait x
after cancel $timer
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} {
set x $sock
} else {
puts $sock hello
flush $sock
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} {
removeFile 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]"
close $file
set x done
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
if {[catch {socket 127.0.0.1 $listen} sock]} {
set x $sock
} else {
puts $sock hello
flush $sock
lappend x [gets $f]
close $sock
}
close $f
set x
} {ready hello}
test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
removeFile 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]"
close $file
set x done
}
puts ready
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f x
gets $f listen
if {[catch {socket 127.0.0.1 $listen} sock]} {
set x $sock
} else {
puts $sock hello
flush $sock
|
| ︙ | ︙ | |||
427 428 429 430 431 432 433 |
}
close $sock
}
set status
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
removeFile script
| | | 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 |
}
close $sock
}
set status
} ok
test socket-2.7 {echo server, one line} {socket stdio} {
removeFile 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
}
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 |
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
puts $x
}
close $f
| | | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
puts $x
}
close $f
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 -translation lf
puts $s "hello abcdefghijklmnop"
after 1000
set x [gets $s]
|
| ︙ | ︙ | |||
494 495 496 497 498 499 500 |
puts [lindex [fconfigure $f -sockname] 2]
set timer [after 20000 "set x done"]
vwait x
after cancel $timer
close $f
puts "done $i"
} script
| | | | | 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 |
puts [lindex [fconfigure $f -sockname] 2]
set timer [after 20000 "set x done"]
vwait x
after cancel $timer
close $f
puts "done $i"
} script
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
} {done 50}
test socket-2.9 {socket conflict} {socket stdio} {
set s [socket -server accept 0]
removeFile 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]]
regsub "\n.*$" $msg {} msg ; # cut part of the error message containing the port number
lappend x $msg
close $s
set x
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
close $sock
set result
} {a:one b: c:two}
test socket-3.1 {socket conflict} {socket stdio} {
removeFile script
| | | | | 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 |
close $sock
set result
} {a:one b: c:two}
test socket-3.1 {socket conflict} {socket stdio} {
removeFile 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} {
removeFile 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]
proc accept {s a p} {
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
after cancel $t2
vwait x
after cancel $t3
close $s
puts $x
}
close $f
| | | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 |
after cancel $t2
vwait x
after cancel $t3
close $s
puts $x
}
close $f
set f [open "|[list [interpreter] $path(script)]" r+]
set x [gets $f]
gets $f listen
set s1 [socket 127.0.0.1 $listen]
fconfigure $s1 -buffering line
set s2 [socket 127.0.0.1 $listen]
fconfigure $s2 -buffering line
set s3 [socket 127.0.0.1 $listen]
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 |
lappend x [gets $f]
close $f
set x
} {ready done}
test socket-4.1 {server with several clients} {socket stdio} {
removeFile script
| | | | | | 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 |
lappend x [gets $f]
close $f
set x
} {ready done}
test socket-4.1 {server with several clients} {socket stdio} {
removeFile 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
gets $s
}
close $s
puts bye
gets stdin
}
close $f
set p1 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p1 -buffering line
set p2 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p2 -buffering line
set p3 [open "|[list [interpreter] $path(script)]" r+]
fconfigure $p3 -buffering line
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
}
proc echo {s} {
global x
|
| ︙ | ︙ | |||
759 760 761 762 763 764 765 |
close $msg
}
set x
} {couldn't open socket: not owner}
test socket-6.1 {accept callback error} {socket stdio} {
removeFile script
| | | | | | | | 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 |
close $msg
}
set x
} {couldn't open socket: not owner}
test socket-6.1 {accept callback error} {socket stdio} {
removeFile 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+]
proc bgerror args {
global x
set x $args
}
proc accept {s a p} {expr 10 / 0}
set s [socket -server accept 0]
puts $f [lindex [fconfigure $s -sockname] 2]
close $f
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
rename bgerror {}
set x
} {{divide by zero}}
test socket-7.1 {testing socket specific options} {socket stdio} {
removeFile script
set f [open $path(script) w]
puts $f {
set ss [socket -server accept 0]
proc accept args {
global x
set x done
}
puts ready
puts [lindex [fconfigure $ss -sockname] 2]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
gets $f listen
set s [socket 127.0.0.1 $listen]
set p [fconfigure $s -peername]
close $s
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} {
removeFile script
set f [open $path(script) w]
puts $f {
set ss [socket -server accept 2821]
proc accept args {
global x
set x done
}
puts ready
puts [lindex [fconfigure $ss -sockname] 2]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
gets $f
gets $f listen
set s [socket 127.0.0.1 $listen]
set p [fconfigure $s -sockname]
close $s
close $f
list [llength $p] \
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 |
set timer [after 10000 "set done timed_out"]
vwait done
after cancel $timer
sendCommand {close $l}
set count
} 65566
| > > > | | | | | | | | | | | | | | | | | 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 |
set timer [after 10000 "set done timed_out"]
vwait done
after cancel $timer
sendCommand {close $l}
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} {
removeFile script1
removeFile 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 $f [format {
set f [socket -server accept 0]
puts [lindex [fconfigure $f -sockname] 2]
proc accept { file addr port } {
close $file
}
exec $tcltest "%s" &
close $f
after 1000 exit
vwait forever
} $path(script1)]
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}
}
removeFile script1
removeFile script2
close $p
set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
removeFile script1
removeFile 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 $f [format {
gets stdin port
set f [socket 127.0.0.1 $port]
exec $tcltest "%s" &
puts $f testing
flush $f
after 1000 exit
vwait forever
} $path(script1)]
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
|
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 |
# If the socket doesn't hit end-of-file in 10 seconds, the
# script1 process must have inherited the client.
set failed 0
after 10000 [list set failed 1]
# Launch the script2 process
| | | | | | | | | | | | | 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 |
# If the socket doesn't hit end-of-file in 10 seconds, the
# script1 process must have inherited the client.
set failed 0
after 10000 [list set failed 1]
# Launch the script2 process
### exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" w]
puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
vwait x
if {!$failed} {
vwait failed
}
removeFile script1
removeFile script2
close $p
set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
removeFile script1
removeFile 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 $f [format {
set server [socket -server accept 0]
puts stdout [lindex [fconfigure $server -sockname] 2]
proc accept { file host port } {
global tcltest
puts $file {test data on socket}
exec $tcltest "%s" &
after 1000 exit
}
vwait forever
} $path(script1)]
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]
gets $p listen
after 1000 set ok_to_proceed 1
vwait ok_to_proceed
set f [socket 127.0.0.1 $listen]
fconfigure $f -buffering full -blocking 0
|
| ︙ | ︙ |
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 |
# 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.
#
# RCS: @(#) $Id: source.test,v 1.7.14.1 2002/08/20 20:25:29 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
set sourcefile [makeFile "" source.file]
test source-1.1 {source command} {
set x "old x value"
set y "old y value"
set z "old z value"
makeFile {
set x 22
set y 33
set z 44
} source.file
source $sourcefile
list $x $y $z
} {22 33 44}
test source-1.2 {source command} {
makeFile {list result} source.file
source $sourcefile
} result
test source-1.3 {source command} {
set y {\ }
set fd [open $sourcefile w]
fconfigure $fd -translation lf
puts -nonewline $fd "list a b c "
puts $fd [string index $y 0]
puts $fd "d e f"
close $fd
source $sourcefile
} {a b c d e f}
test source-2.3 {source error conditions} {
makeFile {
set x 146
error "error in sourced file"
set y $x
} source.file
list [catch {source $sourcefile} msg] $msg $errorInfo
} [list 1 {error in sourced file} "error in sourced file
while executing
\"error \"error in sourced file\"\"
(file \"$sourcefile\" line 3)
invoked from within
\"source \$sourcefile\""]
test source-2.4 {source error conditions} {
makeFile {break} source.file
catch {source $sourcefile}
} 3
test source-2.5 {source error conditions} {
makeFile {continue} source.file
catch {source $sourcefile}
} 4
test source-2.6 {source error conditions} {
normalizeMsg [list [catch {source _non_existent_} msg] $msg $errorCode]
} {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} {
makeFile {
set x new-x
return allDone
set y new-y
} source.file
set x old-x
set y old-y
set z [source $sourcefile]
list $x $y $z
} {new-x old-y allDone}
test source-3.2 {return with special code etc.} {
makeFile {
set x new-x
return -code break "Silly result"
set y new-y
} source.file
list [catch {source $sourcefile} msg] $msg
} {3 {Silly result}}
test source-3.3 {return with special code etc.} {
makeFile {
set x new-x
return -code error "Simulated error"
set y new-y
} source.file
list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode
} {1 {Simulated error} {Simulated error
while executing
"source $sourcefile"} NONE}
test source-3.4 {return with special code etc.} {
makeFile {
set x new-x
return -code error -errorinfo "Simulated errorInfo stuff"
set y new-y
} source.file
list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode
} {1 {} {Simulated errorInfo stuff
invoked from within
"source $sourcefile"} NONE}
test source-3.5 {return with special code etc.} {
makeFile {
set x new-x
return -code error -errorinfo "Simulated errorInfo stuff" \
-errorcode {a b c}
set y new-y
} source.file
list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode
} {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} {macOnly} {
list [catch {source -rsrc _no_exist_} msg] $msg
} [list 1 "The resource \"_no_exist_\" could not be loaded from application."]
test source-4.2 {source error conditions} {macOnly} {
list [catch {source -rsrcid bad_id} msg] $msg
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
list [catch {source -bad_switch argument} msg] $msg
} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test source-5.1 {source resource files} {macOnly} {
list [catch {source -rsrc rsrcName bad_file} msg] $msg
} [list 1 "Error finding the file: \"bad_file\"."]
test source-5.2 {source resource files} {macOnly} {
makeFile {return} source.file
| | | | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
list [catch {source -bad_switch argument} msg] $msg
} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}}
test source-5.1 {source resource files} {macOnly} {
list [catch {source -rsrc rsrcName bad_file} msg] $msg
} [list 1 "Error finding the file: \"bad_file\"."]
test source-5.2 {source resource files} {macOnly} {
makeFile {return} source.file
list [catch {source -rsrc rsrcName $sourcefile} msg] $msg
} [list 1 "Error reading the file: \"$sourcefile\"."]
test source-5.3 {source resource files} {macOnly} {
testWriteTextResource -rsrc rsrcName -file rsrc.file {set msg2 ok; return}
set result [catch {source -rsrc rsrcName rsrc.file} msg]
removeFile rsrc.file
list $msg2 $result $msg
} [list ok 0 {}]
test source-5.4 {source resource files} {macOnly} {
|
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
removeFile rsrc.file
list $msg2 $result $msg
} [list hello 1 bad]
test source-6.1 {source is binary ok} {
set x {}
makeFile [list set x "a b\0c"] source.file
| | | < < < < < < < < < < < < | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
removeFile rsrc.file
list $msg2 $result $msg
} [list hello 1 bad]
test source-6.1 {source is binary ok} {
set x {}
makeFile [list set x "a b\0c"] source.file
source $sourcefile
string length $x
} 5
test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} {
set x {}
makeFile [list set x "ab\32c"] source.file
source $sourcefile
string length $x
} 2
# cleanup
catch {::tcltest::removeFile source.file}
::tcltest::cleanupTests
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 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 |
# 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.11.4.3 2002/08/20 20:25:29 das 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.
# In order to avoid that, we do a basic check of the current stacksize.
# This size can be changed with ulimit (ksh/bash/sh) or limit (csh/tcsh).
# This doesn't catch all cases, for example threads of lower stacksize
# can still squeak through. A core check is really needed. -- JH
if {[string equal $::tcl_platform(platform) "unix"]} {
set stackSize [exec /bin/sh -c "ulimit -s"]
if {[string is integer $stackSize] && ($stackSize < 2400)} {
puts stderr "WARNING: the default application stacksize of $stackSize\
may cause Tcl to\ncrash due to stack overflow before the\
recursion limit is reached.\nA minimum stacksize of 2400\
kbytes is recommended.\nSkipping infinite recursion test."
::tcltest::testConstraint minStack2400 0
} else {
::tcltest::testConstraint minStack2400 1
}
} else {
::tcltest::testConstraint minStack2400 1
}
test stack-1.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
proc recurse {} { return [recurse] }
catch {recurse} rv
rename recurse {}
set rv
} {too many nested evaluations (infinite loop?)}
test stack-2.1 {maxNestingDepth reached on infinite recursion} {minStack2400} {
# do this in a slave to not mess with parent
set slave stack-2.1
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
|
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.9.8.2 2002/08/20 20:25:29 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test subst-1.1 {basics} {
|
| ︙ | ︙ | |||
90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
set a 0
list [catch {subst {0[set a 1}} msg] $a $msg
} {1 0 {missing close-bracket}}
test subst-5.7 {command substitutions} {
set a 0
list [catch {subst {0[set a 1; set a 2}} msg] $a $msg
} {1 1 {missing close-bracket}}
test subst-6.1 {clear the result after command substitution} {
catch {unset a}
list [catch {subst {[concat foo] $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test subst-7.1 {switches} {
| > > > > > > > > > > > > > > | 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 |
set a 0
list [catch {subst {0[set a 1}} msg] $a $msg
} {1 0 {missing close-bracket}}
test subst-5.7 {command substitutions} {
set a 0
list [catch {subst {0[set a 1; set a 2}} msg] $a $msg
} {1 1 {missing close-bracket}}
# repeat the tests above simulating cmd line input
test subst-5.8 {command substitutions} {
set script {[subst {[set a 1}]}
list [catch {exec [info nameofexecutable] << $script} msg] $msg
} {1 {missing close-bracket}}
test subst-5.9 {command substitutions} {
set script {[subst {0[set a 1}]}
list [catch {exec [info nameofexecutable] << $script} msg] $msg
} {1 {missing close-bracket}}
test subst-5.10 {command substitutions} {
set script {[subst {0[set a 1; set a 2}]}
list [catch {exec [info nameofexecutable] << $script} msg] $msg
} {1 {missing close-bracket}}
test subst-6.1 {clear the result after command substitution} {
catch {unset a}
list [catch {subst {[concat foo] $a}} msg] $msg
} {1 {can't read "a": no such variable}}
test subst-7.1 {switches} {
|
| ︙ | ︙ |
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 17 18 19 20 21 22 23 24 25 26 |
# 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.16.8.3 2002/08/20 20:25:29 das 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].
#
# It would be better to have the -body of the tests run the tcltest
# commands in a slave interp so the [test] being tested would not
# interfere with the [test] doing the testing.
#
if {[catch {package require tcltest 2.1}]} {
puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
return
}
|
| ︙ | ︙ | |||
47 48 49 50 51 52 53 54 |
test d-1.0 {test d} {
error "foo" foo 9
} {}
tcltest::cleanupTests
exit
} test.tcl
# test -help
| > > > | < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | 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 |
test d-1.0 {test d} {
error "foo" foo 9
} {}
tcltest::cleanupTests
exit
} test.tcl
cd [temporaryDirectory]
testConstraint exec [llength [info commands exec]]
# test -help
# Child processes because -help [exit]s.
test tcltest-1.1 {tcltest -help} {exec} {
set result [catch {exec [interpreter] test.tcl -help} msg]
list $result [regexp Usage $msg]
} {1 1}
test tcltest-1.2 {tcltest -help -something} {exec} {
set result [catch {exec [interpreter] test.tcl -help -something} msg]
list $result [regexp Usage $msg]
} {1 1}
test tcltest-1.3 {tcltest -h} {exec} {
set result [catch {exec [interpreter] test.tcl -h} msg]
list $result [regexp Usage $msg]
} {1 0}
# -verbose, implicit & explicit testing of [verbose]
proc slave {msgVar args} {
upvar 1 $msgVar msg
interp create [namespace current]::i
# Fake the slave interp into dumping output to a file
i eval {namespace eval ::tcltest {}}
i eval "set tcltest::outputChannel \[open [makeFile {} output] w]"
i eval "set tcltest::errorChannel \[open [makeFile {} error] w]"
i eval [list set argv0 [lindex $args 0]]
i eval [list set argv [lrange $args 1 end]]
i eval [list package ifneeded tcltest [package provide tcltest] \
[package ifneeded tcltest [package provide tcltest]]]
i eval {proc exit args {}}
# Need to capture output in msg
set code [catch {i eval {source $argv0}} foo]
if $code {
#puts "$code: $foo\n$::errorInfo"
}
i eval {close $tcltest::outputChannel}
interp delete [namespace current]::i
set f [open [file join [temporaryDirectory] output]]
set msg [read -nonewline $f]
close $f
set f [open [file join [temporaryDirectory] error]]
set err [read -nonewline $f]
close $f
if {[string length $err]} {
set code 1
append msg \n$err
}
return $code
# return [catch {uplevel 1 [linsert $args 0 exec [interpreter]]} msg]
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
set result [slave msg test.tcl]
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
set result [slave msg test.tcl -verbose 'b']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 0 0 1}
test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
set result [slave msg test.tcl -verbose 'p']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 0 1}
test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
set result [slave msg test.tcl -verbose 's']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 0 1 1}
test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
set result [slave msg test.tcl -verbose 'ps']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 0 1 1 1}
test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
set result [slave msg test.tcl -verbose 'psb']
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
set result [slave msg test.tcl -verbose "pass skip body"]
list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
[regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-2.6 {tcltest -verbose 't'} {
-constraints {unixOrPc}
-body {
set result [slave msg test.tcl -verbose 't']
list $result $msg
}
-result {^0 .*a-1.0 start.*b-1.0 start}
-match regexp
}
test tcltest-2.6a {tcltest -verbose 'start'} {
-constraints {unixOrPc}
-body {
set result [slave msg test.tcl -verbose start]
list $result $msg
}
-result {^0 .*a-1.0 start.*b-1.0 start}
-match regexp
}
test tcltest-2.7 {tcltest::verbose} {
-body {
set oldVerbosity [verbose]
verbose bar
set currentVerbosity [verbose]
verbose foo
set newVerbosity [verbose]
verbose $oldVerbosity
list $currentVerbosity $newVerbosity
}
-result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
-constraints {unixOrPc}
-body {
set result [slave msg test.tcl -verbose error]
list $result $msg
}
-result {errorInfo: foo.*errorCode: 9}
-match regexp
}
# -match, [match]
test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
set result [slave msg test.tcl -match a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
set result [slave msg test.tcl -match b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 1 0 1}
test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
set result [slave msg test.tcl -match c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 1 0 1}
test tcltest-3.5 {tcltest::match} {
-body {
set oldMatch [match]
match foo
set currentMatch [match]
match bar
set newMatch [match]
match $oldMatch
list $currentMatch $newMatch
}
-result {foo bar}
}
# -skip, [skip]
test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
set result [slave msg test.tcl -skip a* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
} {0 0 1 1 1}
test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
set result [slave msg test.tcl -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
} {0 1 0 1 1}
test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
set result [slave msg test.tcl -skip c* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
} {0 1 1 0 1}
test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
} {0 0 0 1 1}
test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 1 0 0 1}
test tcltest-4.6 {tcltest::skip} {
-body {
set oldSkip [skip]
skip foo
set currentSkip [skip]
skip bar
set newSkip [skip]
skip $oldSkip
list $currentSkip $newSkip
}
-result {foo bar}
}
# -constraints, -limitconstraints, [testConstraint],
# $constraintsSpecified, [limitConstraints]
test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
} {0 1 1 1 1}
test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
[regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
} {0 0 0 1 1}
test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)} {
-body {
set r1 [testConstraint tcltestFakeConstraint]
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
#}
test tcltest-5.5 {InitConstraints: list of built-in constraints} \
-constraints {!singleTestInterp} \
-setup {tcltest::InitConstraints} \
-body { lsort [array names ::tcltest::testConstraints] } \
-result [lsort {
| | | | | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 |
#}
test tcltest-5.5 {InitConstraints: list of built-in constraints} \
-constraints {!singleTestInterp} \
-setup {tcltest::InitConstraints} \
-body { lsort [array names ::tcltest::testConstraints] } \
-result [lsort {
95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive
knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles
nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket
stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs
unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly
}]
# Removed this broken test. Its usage of [limitConstraints] was not
# in agreement with the documentation. [limitConstraints] is supposed
# to take an optional boolean argument, and "knownBug" ain't no boolean!
#test tcltest-5.6 {tcltest::limitConstraints} {
# -setup {
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
exit
} printerror.tcl]
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
-constraints unixOrPc
-body {
| | | | | | 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 |
::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
exit
} printerror.tcl]
test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
-constraints unixOrPc
-body {
slave msg $printerror
return $msg
}
-result {a test.*a really}
-match regexp
}
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
slave msg $printerror -outfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {0 1 0 1 1 {}}
test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
slave msg $printerror -errfile a.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" a.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 [file exists a.tmp] [file delete a.tmp]
} {1 0 1 0 1 {}}
test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
slave msg printerror.tcl -outfile a.tmp -errfile b.tmp
set result1 [catch {exec grep "a test" a.tmp}]
set result2 [catch {exec grep "a really" b.tmp}]
list [regexp "a test" $msg] [regexp "a really" $msg] \
$result1 $result2 \
[file exists a.tmp] [file delete a.tmp] \
[file exists b.tmp] [file delete b.tmp]
} {0 0 0 0 1 {} 1 {}}
|
| ︙ | ︙ | |||
424 425 426 427 428 429 430 431 432 433 434 435 436 437 |
-match regexp
-cleanup {
outputFile $of
}
}
# -debug, [debug]
test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
catch {exec [interpreter] test.tcl -debug 0} msg
regexp "Flags passed into tcltest" $msg
} {0}
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
list [regexp userSpecifiedSkip $msg] \
| > > > | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
-match regexp
-cleanup {
outputFile $of
}
}
# -debug, [debug]
# Must use child processes to test -debug because it always writes
# messages to stdout, and we have no way to capture stdout of a
# slave interp
test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
catch {exec [interpreter] test.tcl -debug 0} msg
regexp "Flags passed into tcltest" $msg
} {0}
test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
list [regexp userSpecifiedSkip $msg] \
|
| ︙ | ︙ | |||
471 472 473 474 475 476 477 |
}
# directory tests
makeFile {
package require tcltest
tcltest::makeFile {} a.tmp
| | | | < < | | | | < | | < | | | < | | | | > | | | < | | < | | > > < | 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 |
}
# directory tests
makeFile {
package require tcltest
tcltest::makeFile {} a.tmp
puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
exit
} a.tcl
makeFile {} thisdirectoryisafile
set normaldirectory [makeDirectory normaldirectory]
if {$::tcl_platform(platform) == "macintosh"} {
set normaldirectory [file normalize $normaldirectory]
}
# -tmpdir, [temporaryDirectory]
test tcltest-8.1 {tcltest a.tcl -tmpdir a} {unixOrPc} {
file delete -force thisdirectorydoesnotexist
slave msg a.tcl -tmpdir thisdirectorydoesnotexist
list [file exists [file join thisdirectorydoesnotexist a.tmp]] \
[file delete -force thisdirectorydoesnotexist]
} {1 {}}
test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
-constraints unixOrPc
-body {
slave msg a.tcl -tmpdir thisdirectoryisafile
set msg
}
-result {*not a directory*}
-match glob
}
# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]
makeDirectory notreadable
makeDirectory notwriteable
switch $tcl_platform(platform) {
"unix" {
file attributes $notReadableDir -permissions 00333
file attributes $notWriteableDir -permissions 00555
}
default {
catch {file attributes $notWriteableDir -readonly 1}
}
}
test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {unixOnly} {
slave msg a.tcl -tmpdir $notReadableDir
string match {*not readable*} $msg
} {1}
test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {unixOrPc} {
slave msg a.tcl -tmpdir $notWriteableDir
string match {*not writeable*} $msg
} {1}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {unixOrPc} {
slave msg a.tcl -tmpdir $normaldirectory
# The join is necessary because the message can be split on multiple lines
list [file exists [file join $normaldirectory a.tmp]] \
[file delete [file join $normaldirectory a.tmp]]
} {1 {}}
cd [workingDirectory]
test tcltest-8.6 {temporaryDirectory} {
-setup {
set old $::tcltest::temporaryDirectory
set ::tcltest::temporaryDirectory $normaldirectory
}
-body {
set f1 [temporaryDirectory]
set f2 [temporaryDirectory [workingDirectory]]
set f3 [temporaryDirectory]
list $f1 $f2 $f3
}
-result "[list $normaldirectory [workingDirectory] [workingDirectory]]"
-cleanup {
set ::tcltest::temporaryDirectory $old
}
}
test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
set old $::tcltest::temporaryDirectory
set ::tcltest::temporaryDirectory $normaldirectory
} -body {
set f1 [temporaryDirectory]
set f2 [temporaryDirectory [workingDirectory]]
set f3 [temporaryDirectory]
list $f1 $f2 $f3
} -cleanup {
set ::tcltest::temporaryDirectory $old
} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
cd [temporaryDirectory]
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {unixOrPc} {
file delete -force thisdirectorydoesnotexist
slave msg a.tcl -testdir thisdirectorydoesnotexist
string match "*does not exist*" $msg
} {1}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {unixOrPc} {
slave msg a.tcl -testdir thisdirectoryisafile
string match "*not a directory*" $msg
} {1}
test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {unixOnly} {
slave msg a.tcl -testdir $notReadableDir
string match {*not readable*} $msg
} {1}
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {unixOrPc} {
slave msg a.tcl -testdir $normaldirectory
# The join is necessary because the message can be split on multiple lines
list [string first "testdir: $normaldirectory" [join $msg]] \
[file exists [file join [temporaryDirectory] a.tmp]] \
[file delete [file join [temporaryDirectory] a.tmp]]
} {0 1 {}}
cd [workingDirectory]
set current [pwd]
test tcltest-8.14 {testsDirectory} {
-setup {
set old $::tcltest::testsDirectory
set ::tcltest::testsDirectory $normaldirectory
}
-body {
set f1 [testsDirectory]
set f2 [testsDirectory $current]
set f3 [testsDirectory]
list $f1 $f2 $f3
|
| ︙ | ︙ | |||
657 658 659 660 661 662 663 |
}
}
file delete -force $notReadableDir $notWriteableDir
# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file a*.tcl} {unixOrPc} {
| < | < | | | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 |
}
}
file delete -force $notReadableDir $notWriteableDir
# -file, -notfile, [matchFiles], [skipFiles]
test tcltest-9.1 {-file a*.tcl} {unixOrPc} {
slave msg [file join [testsDirectory] all.tcl] -file a*.test
list [regexp assocd\.test $msg]
} {1}
test tcltest-9.2 {-file a*.tcl} {unixOrPc} {
slave msg [file join [testsDirectory] all.tcl] \
-file a*.test -notfile assocd*
list [regexp assocd\.test $msg]
} {0}
test tcltest-9.3 {matchFiles} {
-body {
set old [matchFiles]
matchFiles foo
|
| ︙ | ︙ | |||
706 707 708 709 710 711 712 713 |
set f [open core w]
close $f
} {}
::tcltest::cleanupTests
return
} makecore.tcl
test tcltest-10.1 {-preservecore 0} {unixOrPc} {
| > | | | | > > > | | | | | | | < > | > | < | > | > | | > | 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 |
set f [open core w]
close $f
} {}
::tcltest::cleanupTests
return
} makecore.tcl
cd [temporaryDirectory]
test tcltest-10.1 {-preservecore 0} {unixOrPc} {
slave msg makecore.tcl -preservecore 0
file delete core
regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrPc} {
slave msg makecore.tcl -preservecore 1
file delete core
regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrPc} {
slave msg makecore.tcl -preservecore 2
file delete core
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
test tcltest-10.4 {-preservecore 3} {unixOrPc} {
slave msg makecore.tcl -preservecore 3
file delete core
list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
[regexp "core-" $msg] [file delete core-makecore]
} {1 1 1 {}}
# Removing this test. It makes no sense to test the ability of
# [preserveCore] to accept an invalid value that will cause errors
# in other parts of tcltest's operation.
#test tcltest-10.5 {preserveCore} {
# -body {
# set old [preserveCore]
# set result [preserveCore foo]
# set result2 [preserveCore]
# preserveCore $old
# list $result $result2
# }
# -result {foo foo}
#}
# -load, -loadfile, [loadScript], [loadFile]
set contents {
package require tcltest
namespace import tcltest::*
puts [outputChannel] $::tcltest::loadScript
exit
}
set loadfile [makeFile $contents load.tcl]
test tcltest-12.1 {-load xxx} {unixOrPc} {
slave msg load.tcl -load xxx
set msg
} {xxx}
# Using child process because of -debug usage.
test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
catch {exec [interpreter] load.tcl -debug 2 -loadfile load.tcl} msg
list \
[regexp {tcltest} [join [list $msg] [split $msg \n]]] \
[regexp {loadScript} [join [list $msg] [split $msg \n]]]
} {1 1}
|
| ︙ | ︙ | |||
789 790 791 792 793 794 795 |
set f1 [loadScript]
set f2 [loadFile]
set f3 [loadFile load.tcl]
set f4 [loadScript]
set f5 [loadFile]
list $f1 $f2 $f3 $f4 $f5
}
| | < < < < | 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 |
set f1 [loadScript]
set f2 [loadFile]
set f3 [loadFile load.tcl]
set f4 [loadScript]
set f5 [loadFile]
list $f1 $f2 $f3 $f4 $f5
}
-result "[list {} {} $loadfile $contents $loadfile]\n"
-cleanup {
set ::tcltest::loadScript $olds
set ::tcltest::loadFile $oldf
}
}
# [interpreter]
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 841 842 843 844 |
set allfile [makeFile {
package require tcltest
namespace import tcltest::*
testsDirectory [file join [temporaryDirectory] singleprocdir]
runAllTests
} [file join singleprocdir all-single.tcl]]
test tcltest-14.1 {-singleproc - single process} {
-constraints {unixOrPc}
-body {
| > | > | > | 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 |
set allfile [makeFile {
package require tcltest
namespace import tcltest::*
testsDirectory [file join [temporaryDirectory] singleprocdir]
runAllTests
} [file join singleprocdir all-single.tcl]]
cd [workingDirectory]
test tcltest-14.1 {-singleproc - single process} {
-constraints {unixOrPc}
-body {
slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
set msg
}
-result {Test file error: can't unset .foo.: no such variable}
-match regexp
}
test tcltest-14.2 {-singleproc - multiple process} {
-constraints {unixOrPc}
-body {
slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
set msg
}
-result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
-match regexp
}
test tcltest-14.3 {singleProcess} {
-setup {
|
| ︙ | ︙ | |||
907 908 909 910 911 912 913 |
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
runAllTests
} [file join dirtestdir dirtestdir2.3 all.tcl]
test tcltest-15.1 {basic directory walking} {
-constraints {unixOrPc}
-body {
| > | > > > | | > > > | | > > > | | > > | | > > > | 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 |
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
runAllTests
} [file join dirtestdir dirtestdir2.3 all.tcl]
test tcltest-15.1 {basic directory walking} {
-constraints {unixOrPc}
-body {
if {[slave msg \
[file join [temporaryDirectory] dirtestdir all.tcl] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*Tests located in:.*dirtestdir2.3}
}
test tcltest-15.2 {-asidefromdir} {
-constraints {unixOrPc}
-body {
if {[slave msg \
[file join [temporaryDirectory] dirtestdir all.tcl] \
-asidefromdir dirtestdir2.3 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.1.*Tests located in:.*dirtestdir2.2.*dirtestdir2.2 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}
-body {
if {[slave msg \
[file join [temporaryDirectory] dirtestdir all.tcl] \
-relateddir [file join [temporaryDirectory] dirtestdir0] \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-returnCodes 1
-match regexp
-result {[^~]|dirtestdir[^2]}
}
test tcltest-15.4 {-relateddir, subdir} {
-constraints {unixOrPc}
-body {
if {[slave msg \
[file join [temporaryDirectory] dirtestdir all.tcl] \
-relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-returnCodes 1
-match regexp
-result {Tests located in:.*dirtestdir2.[^23]}
}
test tcltest-15.5 {-relateddir, -asidefromdir} {
-constraints {unixOrPc}
-body {
if {[slave msg \
[file join [temporaryDirectory] dirtestdir all.tcl] \
-relateddir "dirtestdir2.1 dirtestdir2.2" \
-asidefromdir dirtestdir2.2 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
}
}
-match regexp
-returnCodes 1
-result {Tests located in:.*dirtestdir2.[^23]}
}
test tcltest-15.6 {matchDirectories} {
|
| ︙ | ︙ | |||
1001 1002 1003 1004 1005 1006 1007 |
set ::tcltest::skipDirectories $old
}
-result {{} foo foo}
}
# TCLTEST_OPTIONS
test tcltest-19.1 {TCLTEST_OPTIONS default} {
| | | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
set ::tcltest::skipDirectories $old
}
-result {{} foo foo}
}
# TCLTEST_OPTIONS
test tcltest-19.1 {TCLTEST_OPTIONS default} {
-constraints {unixOrPc singleTestInterp}
-setup {
if {[info exists ::env(TCLTEST_OPTIONS)]} {
set oldoptions $::env(TCLTEST_OPTIONS)
unset ::env(TCLTEST_OPTIONS)
} else {
set oldoptions none
}
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 1042 1043 |
-result {^$}
-match regexp
-output {tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
}
# Begin testing of tcltest procs ...
# PrintError
test tcltest-20.1 {PrintError} {unixOrPc} {
| > | > | > > > > > | 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 |
-result {^$}
-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.tcl]
list $result [regexp "Error: a really short string" $msg] \
[regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \
[regexp " \"Really" $msg] [regexp Problem $msg]
} {1 1 1 1 1 1}
cd [workingDirectory]
# test::test
test tcltest-21.0 {name and desc but no args specified} -setup {
set v [verbose]
} -cleanup {
verbose $v
} -body {
verbose {}
test tcltest-21.0.0 bar
} -result {}
test tcltest-21.1 {expect with glob} {
-body {
list a b c d e
}
|
| ︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 |
test tcltest-21.4 {test command with cleanup failure} {
-setup {
if {[info exists foo]} {
unset foo
}
set fail $::tcltest::currentFailure
}
-body {
test tcltest-21.4.0 {foo-1} {
-cleanup {unset foo}
}
}
-result {^$}
-match regexp
| > > | | 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 |
test tcltest-21.4 {test command with cleanup failure} {
-setup {
if {[info exists foo]} {
unset foo
}
set fail $::tcltest::currentFailure
set v [verbose]
}
-body {
verbose {}
test tcltest-21.4.0 {foo-1} {
-cleanup {unset foo}
}
}
-result {^$}
-match regexp
-cleanup {verbose $v; set ::tcltest::currentFailure $fail}
-output "Test cleanup failed:.*can't unset \"foo\": no such variable"
}
test tcltest-21.5 {test command with setup failure} {
-setup {
if {[info exists foo]} {
unset foo
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 |
-result {^$}
-match regexp
-cleanup {set ::tcltest::currentFailure $fail}
-output "Test setup failed:.*can't unset \"foo\": no such variable"
}
test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
| | > | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
-result {^$}
-match regexp
-cleanup {set ::tcltest::currentFailure $fail}
-output "Test setup failed:.*can't unset \"foo\": no such variable"
}
test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
-setup {set v [verbose]; set fail $::tcltest::currentFailure}
-body {
verbose {}
test tcltest-21.6.0 {foo-3} {
-setup {
if {[info exists foo]} {
unset foo
}
set foo 1
set expected 2
|
| ︙ | ︙ | |||
1138 1139 1140 1141 1142 1143 1144 |
} else {
puts [outputChannel] "foo is 2"
}
}
-result {$expected}
}
}
| | | 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 |
} else {
puts [outputChannel] "foo is 2"
}
}
-result {$expected}
}
}
-cleanup {verbose $v; set ::tcltest::currentFailure $fail}
-result {^$}
-match regexp
-output "foo is 2"
}
test tcltest-21.7 {test command - bad flag} {
-setup {set fail $::tcltest::currentFailure}
|
| ︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 |
-result {1}
test tcltest-21.10 {test command with cleanup failure} -setup {
if {[info exists foo]} {
unset foo
}
set fail $::tcltest::currentFailure
} -cleanup {
set ::tcltest::currentFailure $fail
} -body {
| > > > | | > > > | | 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 |
-result {1}
test tcltest-21.10 {test command with cleanup failure} -setup {
if {[info exists foo]} {
unset foo
}
set fail $::tcltest::currentFailure
set v [verbose]
} -cleanup {
verbose $v
set ::tcltest::currentFailure $fail
} -body {
verbose {}
test tcltest-21.10.0 {foo-1} -cleanup {unset foo}
} -result {^$} -match regexp \
-output {Test cleanup failed:.*can't unset \"foo\": no such variable}
test tcltest-21.11 {test command with setup failure} -setup {
if {[info exists foo]} {
unset foo
}
set fail $::tcltest::currentFailure
} -cleanup {set ::tcltest::currentFailure $fail} -body {
test tcltest-21.11.0 {foo-2} -setup {unset foo}
} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp
test tcltest-21.12 {
test command - setup occurs before cleanup & before script
} -setup {
set fail $::tcltest::currentFailure
set v [verbose]
} -cleanup {
verbose $v
set ::tcltest::currentFailure $fail
} -body {
verbose {}
test tcltest-21.12.0 {foo-3} -setup {
if {[info exists foo]} {
unset foo
}
set foo 1
set expected 2
} -body {
incr foo
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 |
test foo-1.1 {foo} {
-body { return 1 }
-result {1}
}
cleanupTests
} [file join alltestdir test.test]
test tcltest-22.1 {runAllTests} {
-constraints {unixOrPc}
-body {
| > > > | > | 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 |
test foo-1.1 {foo} {
-body { return 1 }
-result {1}
}
cleanupTests
} [file join alltestdir test.test]
# Must use a child process because stdout/stderr parsing can't be
# duplicated in slave interp.
test tcltest-22.1 {runAllTests} {
-constraints {unixOrPc}
-body {
exec [interpreter] \
[file join [temporaryDirectory] alltestdir all.tcl] \
-verbose t -tmpdir [temporaryDirectory]
}
-match regexp
-result "Test files exiting with errors:.*error.test.*exit.test"
}
# makeFile, removeFile, makeDirectory, removeDirectory, viewFile
test tcltest-23.1 {makeFile} {
|
| ︙ | ︙ | |||
1409 1410 1411 1412 1413 1414 1415 |
} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}
test tcltest-24.6 {
customMatch: -match script that always matches
} -setup {
customMatch [namespace current]::alwaysMatch "format 1 ;#"
set v [verbose]
| < > < > > > > > > > < > < > < > < > < > < > < > > > > > > > > > > > > > > > > > > > | 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 |
} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}
test tcltest-24.6 {
customMatch: -match script that always matches
} -setup {
customMatch [namespace current]::alwaysMatch "format 1 ;#"
set v [verbose]
} -body {
verbose {}
test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \
-body {format 1} -result 0
} -cleanup {
verbose $v
} -result {} -output {} -errorOutput {}
test tcltest-24.7 {
customMatch: replace default -exact matching
} -setup {
set saveExactMatchScript $::tcltest::CustomMatch(exact)
customMatch exact "format 1 ;#"
set v [verbose]
} -body {
verbose {}
test tcltest-24.7.0 {} -body {format 1} -result 0
} -cleanup {
verbose $v
customMatch exact $saveExactMatchScript
unset saveExactMatchScript
} -result {} -output {}
test tcltest-24.9 {
customMatch: error during match
} -setup {
proc errorDuringMatch args {return -code error "match returned error"}
customMatch [namespace current]::errorDuringMatch \
[namespace code errorDuringMatch]
set v [verbose]
set fail $::tcltest::currentFailure
} -body {
verbose {}
test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch
} -cleanup {
verbose $v
set ::tcltest::currentFailure $fail
} -match glob -result {} -output {*FAILED*match returned error*}
test tcltest-24.10 {
customMatch: bad return from match command
} -setup {
proc nonBooleanReturn args {return foo}
customMatch nonBooleanReturn [namespace code nonBooleanReturn]
set v [verbose]
set fail $::tcltest::currentFailure
} -body {
verbose {}
test tcltest-24.10.0 {} -match nonBooleanReturn
} -cleanup {
verbose $v
set ::tcltest::currentFailure $fail
} -match glob -result {} -output {*FAILED*expected boolean value*}
test tcltest-24.11 {
test: -match exact
} -body {
set result {A B C}
} -match exact -result {A B C}
test tcltest-24.12 {
test: -match exact match command eval in ::, not caller namespace
} -setup {
set saveExactMatchScript $::tcltest::CustomMatch(exact)
customMatch exact [list string equal]
set v [verbose]
proc string args {error {called [string] in caller namespace}}
} -body {
verbose {}
test tcltest-24.12.0 {} -body {format 1} -result 1
} -cleanup {
rename string {}
verbose $v
customMatch exact $saveExactMatchScript
unset saveExactMatchScript
} -match exact -result {} -output {}
test tcltest-24.13 {
test: -match exact failure
} -setup {
set saveExactMatchScript $::tcltest::CustomMatch(exact)
customMatch exact [list string equal]
set v [verbose]
set fail $::tcltest::currentFailure
} -body {
verbose {}
test tcltest-24.13.0 {} -body {format 1} -result 0
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
customMatch exact $saveExactMatchScript
unset saveExactMatchScript
} -match glob -result {} -output {*FAILED*Result was:
1*(exact matching):
0*}
test tcltest-24.14 {
test: -match glob
} -body {
set result {A B C}
} -match glob -result {A B*}
test tcltest-24.15 {
test: -match glob failure
} -setup {
set v [verbose]
set fail $::tcltest::currentFailure
} -body {
verbose {}
test tcltest-24.15.0 {} -match glob -body {format {A B C}} \
-result {A B* }
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(glob matching):
*}
test tcltest-24.16 {
test: -match regexp
} -body {
set result {A B C}
} -match regexp -result {A B.*}
test tcltest-24.17 {
test: -match regexp failure
} -setup {
set fail $::tcltest::currentFailure
set v [verbose]
} -body {
verbose {}
test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \
-result {A B.* X}
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(regexp matching):
*}
test tcltest-24.18 {
test: -match custom forget namespace qualification
} -setup {
set fail $::tcltest::currentFailure
set v [verbose]
customMatch negative matchNegative
} -body {
verbose {}
test tcltest-24.18.0 {} -match negative -body {format {A B C}} \
-result {A B X}
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
} -match glob -result {} -output {*FAILED*Error testing result:*}
test tcltest-24.19 {
test: -match custom
} -setup {
set v [verbose]
customMatch negative [namespace code matchNegative]
} -body {
verbose {}
test tcltest-24.19.0 {} -match negative -body {format {A B C}} \
-result {A B X}
} -cleanup {
verbose $v
} -match exact -result {} -output {}
test tcltest-24.20 {
test: -match custom failure
} -setup {
set fail $::tcltest::currentFailure
set v [verbose]
customMatch negative [namespace code matchNegative]
} -body {
verbose {}
test tcltest-24.20.0 {} -match negative -body {format {A B C}} \
-result {A B C}
} -cleanup {
set ::tcltest::currentFailure $fail
verbose $v
} -match glob -result {} -output {*FAILED*Result was:
*(negative matching):
*}
test tcltest-25.1 {
constraint of setup/cleanup (Bug 589859)
} -setup {
set foo 0
} -body {
# Buggy tcltest will generate result of 2
test tcltest-25.1.0 {} -constraints knownBug -setup {
incr foo
} -body {
incr foo
} -cleanup {
incr foo
} -match glob -result *
set foo
} -cleanup {
unset foo
} -result 0
cleanupTests
}
namespace delete ::tcltest::test
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 |
# 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.11.8.3 2002/08/20 20:25:29 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc traceScalar {name1 name2 op} {
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 |
unset x
array set x {a 1}
set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
catch {unset x}
trace add variable x array traceArray2
| | | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 |
unset x
array set x {a 1}
set ::info
} {}
test trace-5.4 {array traces properly listed in trace information} {
catch {unset x}
trace add variable x array traceArray2
set result [trace info variable x]
set result
} [list [list array traceArray2]]
test trace-5.5 {array traces properly listed in trace information} {
catch {unset x}
trace variable x a traceArray2
set result [trace vinfo x]
set result
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 |
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
catch {unset x}
set x 33
set info {}
| | | | 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 |
unset x
concat $info [list [catch {set x} msg] $msg]
} {0 22 0 22}
test trace-9.3 {be sure traces are cleared before unset trace called} {
catch {unset x}
set x 33
set info {}
trace add variable x unset {traceCheck {uplevel trace info variable x}}
unset x
set info
} {0 {}}
test trace-9.4 {set new trace during unset trace} {
catch {unset x}
set x 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x unset traceProc}}
unset x
concat $info [trace info variable x]
} {0 {} {unset traceProc}}
test trace-10.1 {make sure array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace add variable x(0) unset {traceCheck {uplevel set x(0)}}
|
| ︙ | ︙ | |||
593 594 595 596 597 598 599 |
unset x(0)
concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
| | | | 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 |
unset x(0)
concat $info [list [catch {set x(0)} msg] $msg]
} {0 zzz 0 zzz}
test trace-10.3 {array elements are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace add variable x(0) unset {traceCheck {global x; trace info variable x(0)}}
unset x(0)
set info
} {0 {}}
test trace-10.4 {set new array element trace during unset trace} {
catch {unset x}
set x(0) 33
set info {}
trace add variable x(0) unset {traceCheck {uplevel {trace add variable x(0) read {}}}}
catch {unset x(0)}
concat $info [trace info variable x(0)]
} {0 {} {read {}}}
test trace-11.1 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(0) 33
set info {}
trace add variable x unset {traceCheck {uplevel set x(0)}}
|
| ︙ | ︙ | |||
634 635 636 637 638 639 640 |
unset x
set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(y) 33
set info {}
| | | | 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 |
unset x
set info
} {0 0}
test trace-11.4 {make sure arrays are unset before traces are called} {
catch {unset x}
set x(y) 33
set info {}
set cmd {traceCheck {uplevel {trace info variable x}}}
trace add variable x unset $cmd
unset x
set info
} {0 {}}
test trace-11.5 {set new array trace during unset trace} {
catch {unset x}
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; trace add variable x read {}}}
unset x
concat $info [trace info variable x]
} {0 {} {read {}}}
test trace-11.6 {create scalar during array unset trace} {
catch {unset x}
set x(y) 33
set info {}
trace add variable x unset {traceCheck {global x; set x 44}}
unset x
|
| ︙ | ︙ | |||
758 759 760 761 762 763 764 |
list [catch {trace $op $type foo bar} msg] $msg
} [list 1 "$start should be \"trace $op $type name opList command\""]
test trace-14.0.[incr i] "trace command, wrong # args errors" {
list [catch {trace $op $type foo bar baz boo} msg] $msg
} [list 1 "$start should be \"trace $op $type name opList command\""]
}
test trace-14.0.[incr i] "trace command, wrong # args errors" {
| | | | | | | | | | > | > | 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 |
list [catch {trace $op $type foo bar} msg] $msg
} [list 1 "$start should be \"trace $op $type name opList command\""]
test trace-14.0.[incr i] "trace command, wrong # args errors" {
list [catch {trace $op $type foo bar baz boo} msg] $msg
} [list 1 "$start should be \"trace $op $type name opList command\""]
}
test trace-14.0.[incr i] "trace command, wrong # args errors" {
list [catch {trace info $type foo bar} msg] $msg
} [list 1 "$start should be \"trace info $type name\""]
test trace-14.0.[incr i] "trace command, wrong # args errors" {
list [catch {trace info $type} msg] $msg
} [list 1 "$start should be \"trace info $type name\""]
}
test trace-14.1 "trace command, wrong # args errors" {
list [catch {trace} msg] $msg
} [list 1 "wrong # args: should be \"trace option ?arg arg ...?\""]
test trace-14.2 "trace command, wrong # args errors" {
list [catch {trace add} msg] $msg
} [list 1 "wrong # args: should be \"trace add type ?arg arg ...?\""]
test trace-14.3 "trace command, wrong # args errors" {
list [catch {trace remove} msg] $msg
} [list 1 "wrong # args: should be \"trace remove type ?arg arg ...?\""]
test trace-14.4 "trace command, wrong # args errors" {
list [catch {trace info} msg] $msg
} [list 1 "wrong # args: should be \"trace info type ?arg arg ...?\""]
test trace-14.5 {trace command, invalid option} {
list [catch {trace gorp} msg] $msg
} [list 1 "bad option \"gorp\": must be add, info, remove, variable, vdelete, or vinfo"]
# Again, [trace ... command] and [trace ... variable] share syntax and
# error message styles for their opList options; these loops test those
# error messages.
set i 0
set errs [list "array, read, unset, or write" "delete or rename" "enter, leave, enterstep, or leavestep"]
set abbvs [list {a r u w} {d r} {}]
proc x {} {}
foreach type {variable command execution} err $errs abbvlist $abbvs {
foreach op {add remove} {
test trace-14.6.[incr i] "trace $op $type errors" {
list [catch {trace $op $type x {y z w} a} msg] $msg
} [list 1 "bad operation \"y\": must be $err"]
foreach abbv $abbvlist {
test trace-14.6.[incr i] "trace $op $type rejects abbreviations" {
list [catch {trace $op $type x $abbv a} msg] $msg
} [list 1 "bad operation \"$abbv\": must be $err"]
}
test trace-14.6.[incr i] "trace $op $type rejects null opList" {
list [catch {trace $op $type x {} a} msg] $msg
} [list 1 "bad operation list \"\": must be one or more of $err"]
}
}
rename x {}
test trace-14.7 {trace command, "trace variable" errors} {
list [catch {trace variable} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
test trace-14.8 {trace command, "trace variable" errors} {
list [catch {trace variable x} msg] $msg
} [list 1 "wrong # args: should be \"trace variable name ops command\""]
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 |
set info
} {1}
test trace-14.15 {trace command ("list 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}
| | | | | | | 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 |
set info
} {1}
test trace-14.15 {trace command ("list 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.16 {trace command ("list variable" option)} {
catch {unset x}
trace info variable x
} {}
test trace-14.17 {trace command ("list variable" option)} {
catch {unset x}
trace info variable x(0)
} {}
test trace-14.18 {trace command ("list variable" option)} {
catch {unset x}
set x 44
trace info variable x(0)
} {}
test trace-14.19 {trace command ("list 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}}}
# Check fancy trace commands (long ones, weird arguments, etc.)
test trace-15.1 {long trace command} {
catch {unset x}
|
| ︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 |
trace add variable x unset {traceProc}
list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
catch {unset x}
proc p1 {} {global x; trace add variable x write traceProc}
p1
| | | 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 |
trace add variable x unset {traceProc}
list [catch {unset x} msg] $msg $info
} {1 {can't unset "x": no such variable} {x {} unset}}
test trace-17.2 {traced variables must survive procedure exits} {
catch {unset x}
proc p1 {} {global x; trace add variable x write traceProc}
p1
trace info variable x
} {{write traceProc}}
test trace-17.3 {traced variables must survive procedure exits} {
catch {unset x}
set info {}
proc p1 {} {global x; trace add variable x write traceProc}
p1
set x 44
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 |
rename foo bar
rename bar foo
set info
} {bar foo rename}
test trace-19.2.1 {trace add command rename trace exists} {
proc foo {} {}
trace add command foo rename traceCommand
| | | | 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 |
rename foo bar
rename bar foo
set info
} {bar foo rename}
test trace-19.2.1 {trace add command rename trace exists} {
proc foo {} {}
trace add command foo rename traceCommand
trace info command foo
} {{rename traceCommand}}
test trace-19.3 {command rename traces don't fire on command deletion} {
proc foo {} {}
set info {}
trace add command foo rename traceCommand
rename foo {}
set info
} {}
test trace-19.4 {trace add command rename doesn't trace recreated commands} {
proc foo {} {}
catch {rename bar {}}
trace add command foo rename traceCommand
proc foo {} {}
rename foo bar
set info
} {}
test trace-19.5 {trace add command deleted removes traces} {
proc foo {} {}
trace add command foo rename traceCommand
proc foo {} {}
trace info command foo
} {}
namespace eval tc {}
proc tc::tcfoo {} {}
test trace-19.6 {trace add command rename in namespace} {
trace add command tc::tcfoo rename traceCommand
rename tc::tcfoo tc::tcbar
|
| ︙ | ︙ | |||
1248 1249 1250 1251 1252 1253 1254 |
# Make sure it exists again
proc foo {} {}
test trace-20.1 {trace add command (delete option)} {
trace add command foo delete traceCommand
rename foo ""
set info
| | | | | | | | | | | 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 |
# Make sure it exists again
proc foo {} {}
test trace-20.1 {trace add command (delete option)} {
trace add command foo delete traceCommand
rename foo ""
set info
} {::foo {} delete}
test trace-20.2 {trace add command delete doesn't trace recreated commands} {
set info {}
proc foo {} {}
rename foo ""
set info
} {}
test trace-20.2.1 {trace add command delete trace info} {
proc foo {} {}
trace add command foo delete traceCommand
trace info command foo
} {{delete traceCommand}}
test trace-20.3 {trace add command implicit delete} {
proc foo {} {}
trace add command foo delete traceCommand
proc foo {} {}
set info
} {::foo {} delete}
test trace-20.3.1 {trace add command delete trace info} {
proc foo {} {}
trace info command foo
} {}
test trace-20.4 {trace add command rename followed by delete} {
set infotemp {}
proc foo {} {}
trace add command foo {rename delete} traceCommand
rename foo bar
lappend infotemp $info
rename bar {}
lappend infotemp $info
set info $infotemp
unset infotemp
set info
} {{foo bar rename} {::bar {} delete}}
catch {rename foo {}}
catch {rename bar {}}
test trace-20.5 {trace add command rename and delete} {
set infotemp {}
set info {}
proc foo {} {}
trace add command foo {rename delete} traceCommand
rename foo bar
lappend infotemp $info
rename bar {}
lappend infotemp $info
set info $infotemp
unset infotemp
set info
} {{foo bar rename} {::bar {} delete}}
test trace-20.6 {trace add command rename and delete in subinterp} {
set tc [interp create]
foreach p {traceCommand} {
$tc eval [list proc $p [info args $p] [info body $p]]
}
$tc eval [list set infotemp {}]
$tc eval [list set info {}]
$tc eval [list proc foo {} {}]
$tc eval [list trace add command foo {rename delete} traceCommand]
$tc eval [list rename foo bar]
$tc eval {lappend infotemp $info}
$tc eval [list rename bar {}]
$tc eval {lappend infotemp $info}
$tc eval {set info $infotemp}
$tc eval [list unset infotemp]
set info [$tc eval [list set info]]
interp delete $tc
set info
} {{foo bar rename} {::bar {} delete}}
# I'd like it if this test could give 'foo {} d' as a result,
# but interp deletion means there is no interp to evaluate
# the trace in.
test trace-20.7 {trace add command delete in subinterp while being deleted} {
set info {}
set tc [interp create]
interp alias $tc traceCommand {} traceCommand
$tc eval [list proc foo {} {}]
$tc eval [list trace add command foo {rename delete} traceCommand]
interp delete $tc
set info
} {}
proc traceDelete {cmd old new op} {
eval trace remove command $cmd [lindex [trace info command $cmd] 0]
global info
set info [list $old $new $op]
}
proc traceCmdrename {cmd old new op} {
rename $old someothername
}
proc traceCmddelete {cmd old new op} {
rename $old ""
}
test trace-20.8 {trace delete while trace is active} {
set info {}
proc foo {} {}
catch {rename bar {}}
trace add command foo {rename delete} [list traceDelete foo]
rename foo bar
list [set info] [trace info command bar]
} {{foo bar rename} {}}
test trace-20.9 {rename trace deletes command} {
set info {}
proc foo {} {}
catch {rename bar {}}
catch {rename someothername {}}
|
| ︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 |
# 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 {}}
| > > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > | > > > > > > > > | 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 |
# 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 {}}
proc foo {a} {
set b $a
}
proc traceExecute {args} {
global info
lappend info $args
}
test trace-21.1 {trace execution: enter} {
set info {}
trace add execution foo enter [list traceExecute foo]
foo 1
trace remove execution foo enter [list traceExecute foo]
set info
} {{foo {foo 1} enter}}
test trace-21.2 {trace exeuction: leave} {
set info {}
trace add execution foo leave [list traceExecute foo]
foo 2
trace remove execution foo leave [list traceExecute foo]
set info
} {{foo {foo 2} 0 2 leave}}
test trace-21.3 {trace exeuction: enter, leave} {
set info {}
trace add execution foo {enter leave} [list traceExecute foo]
foo 3
trace remove execution foo {enter leave} [list traceExecute foo]
set info
} {{foo {foo 3} enter} {foo {foo 3} 0 3 leave}}
test trace-21.4 {trace execution: enter, leave, enterstep} {
set info {}
trace add execution foo {enter leave enterstep} [list traceExecute foo]
foo 3
trace remove execution foo {enter leave enterstep} [list traceExecute foo]
set info
} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {foo 3} 0 3 leave}}
test trace-21.5 {trace execution: enter, leave, enterstep, leavestep} {
set info {}
trace add execution foo {enter leave enterstep leavestep} [list traceExecute foo]
foo 3
trace remove execution foo {enter leave enterstep leavestep} [list traceExecute foo]
set info
} {{foo {foo 3} enter} {foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep} {foo {foo 3} 0 3 leave}}
test trace-21.6 {trace execution: enterstep, leavestep} {
set info {}
trace add execution foo {enterstep leavestep} [list traceExecute foo]
foo 3
trace remove execution foo {enterstep leavestep} [list traceExecute foo]
set info
} {{foo {set b 3} enterstep} {foo {set b 3} 0 3 leavestep}}
test trace-21.7 {trace execution: enterstep} {
set info {}
trace add execution foo {enterstep} [list traceExecute foo]
foo 3
trace remove execution foo {enterstep} [list traceExecute foo]
set info
} {{foo {set b 3} enterstep}}
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} {
set info {}
trace add execution factorial {enter} [list traceExecute factorial]
factorial 1
trace remove execution factorial {enter} [list traceExecute factorial]
set info
} {{factorial {factorial 1} enter}}
test trace-22.2 {recursive(2) trace execution: enter} {
set info {}
trace add execution factorial {enter} [list traceExecute factorial]
factorial 2
trace remove execution factorial {enter} [list traceExecute factorial]
set info
} {{factorial {factorial 2} enter} {factorial {factorial 1} enter}}
test trace-22.3 {recursive(3) trace execution: enter} {
set info {}
trace add execution factorial {enter} [list traceExecute factorial]
factorial 3
trace remove execution factorial {enter} [list traceExecute factorial]
set info
} {{factorial {factorial 3} enter} {factorial {factorial 2} enter} {factorial {factorial 1} enter}}
test trace-23.1 {recursive(1) trace execution: enter, leave, enterstep, leavestep} {
set info {}
trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
factorial 1
trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
join $info "\n"
} {{factorial 1} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
{return 1} enterstep
{return 1} 2 1 leavestep
{factorial 1} 0 1 leave}
test trace-23.2 {recursive(2) trace execution: enter, leave, enterstep, leavestep} {
set info {}
trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
factorial 2
trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
join $info "\n"
} {{factorial 2} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
{expr {$n -1 }} enterstep
{expr {$n -1 }} 0 1 leavestep
{factorial 1} enterstep
{factorial 1} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
{return 1} enterstep
{return 1} 2 1 leavestep
{factorial 1} 0 1 leave
{factorial 1} 0 1 leavestep
{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
{return 2} enterstep
{return 2} 2 2 leavestep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
{factorial 2} 0 2 leave}
test trace-23.3 {recursive(3) trace execution: enter, leave, enterstep, leavestep} {
set info {}
trace add execution factorial {enter leave enterstep leavestep} [list traceExecute]
factorial 3
trace remove execution factorial {enter leave enterstep leavestep} [list traceExecute]
join $info "\n"
} {{factorial 3} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
{expr {$n -1 }} enterstep
{expr {$n -1 }} 0 2 leavestep
{factorial 2} enterstep
{factorial 2} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{expr {$n * [factorial [expr {$n -1 }]]}} enterstep
{expr {$n -1 }} enterstep
{expr {$n -1 }} 0 1 leavestep
{factorial 1} enterstep
{factorial 1} enter
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} enterstep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 0 {} leavestep
{return 1} enterstep
{return 1} 2 1 leavestep
{factorial 1} 0 1 leave
{factorial 1} 0 1 leavestep
{expr {$n * [factorial [expr {$n -1 }]]}} 0 2 leavestep
{return 2} enterstep
{return 2} 2 2 leavestep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 2 leavestep
{factorial 2} 0 2 leave
{factorial 2} 0 2 leavestep
{expr {$n * [factorial [expr {$n -1 }]]}} 0 6 leavestep
{return 6} enterstep
{return 6} 2 6 leavestep
{if {$n != 1} { return [expr {$n * [factorial [expr {$n -1 }]]}] }} 2 6 leavestep
{factorial 3} 0 6 leave}
proc traceDelete {cmd args} {
eval trace remove execution $cmd [lindex [trace info execution $cmd] 0]
global info
set info $args
}
test trace-24.1 {delete trace during enter trace} {
set info {}
trace add execution foo enter [list traceDelete foo]
foo 1
list $info [trace info execution foo]
} {{{foo 1} enter} {}}
test trace-24.2 {delete trace during leave trace} {
set info {}
trace add execution foo leave [list traceDelete foo]
foo 1
list $info [trace info execution foo]
} {{{foo 1} 0 1 leave} {}}
test trace-24.3 {delete trace during enter-leave trace} {
set info {}
trace add execution foo {enter leave} [list traceDelete foo]
foo 1
list $info [trace info execution foo]
} {{{foo 1} enter} {}}
test trace-24.4 {delete trace during all exec traces} {
set info {}
trace add execution foo {enter leave enterstep leavestep} [list traceDelete foo]
foo 1
list $info [trace info execution foo]
} {{{foo 1} enter} {}}
test trace-24.5 {delete trace during all exec traces except enter} {
set info {}
trace add execution foo {leave enterstep leavestep} [list traceDelete foo]
foo 1
list $info [trace info execution foo]
} {{{set b 1} enterstep} {}}
proc traceDelete {cmd args} {
rename $cmd {}
global info
set info $args
}
proc foo {a} {
set b $a
}
test trace-25.1 {delete command during enter trace} {
set info {}
trace add execution foo enter [list traceDelete foo]
catch {foo 1} err
list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
proc foo {a} {
set b $a
}
test trace-25.2 {delete command during leave trace} {
set info {}
trace add execution foo leave [list traceDelete foo]
foo 1
list $info [trace info execution foo]
} {{{foo 1} 0 1 leave} {unknown command "foo"}}
proc foo {a} {
set b $a
}
test trace-25.3 {delete command during enter then leave trace} {
set info {}
trace add execution foo enter [list traceDelete foo]
trace add execution foo leave [list traceDelete foo]
catch {foo 1} err
list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
proc foo {a} {
set b $a
}
proc traceExecute2 {args} {
global info
lappend info $args
}
# This shows the peculiar consequences of having two traces
# at the same time: as well as tracing the procedure you want
test trace-25.4 {order dependencies of two enter traces} {
set info {}
trace add execution foo enter [list traceExecute traceExecute]
trace add execution foo enter [list traceExecute2 traceExecute2]
catch {foo 1} err
trace remove execution foo enter [list traceExecute traceExecute]
trace remove execution foo enter [list traceExecute2 traceExecute2]
join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
traceExecute2 {foo 1} enter
traceExecute {foo 1} enter
}
test trace-25.5 {order dependencies of two step traces} {
set info {}
trace add execution foo enterstep [list traceExecute traceExecute]
trace add execution foo enterstep [list traceExecute2 traceExecute2]
catch {foo 1} err
trace remove execution foo enterstep [list traceExecute traceExecute]
trace remove execution foo enterstep [list traceExecute2 traceExecute2]
join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
traceExecute2 {set b 1} enterstep
traceExecute {set b 1} enterstep
}
# We don't want the result string (5th argument), or the results
# will get unmanageable.
proc tracePostExecute {args} {
global info
lappend info [concat [lrange $args 0 2] [lindex $args 4]]
}
proc tracePostExecute2 {args} {
global info
lappend info [concat [lrange $args 0 2] [lindex $args 4]]
}
test trace-25.6 {order dependencies of two leave traces} {
set info {}
trace add execution foo leave [list tracePostExecute tracePostExecute]
trace add execution foo leave [list tracePostExecute2 tracePostExecute2]
catch {foo 1} err
trace remove execution foo leave [list tracePostExecute tracePostExecute]
trace remove execution foo leave [list tracePostExecute2 tracePostExecute2]
join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
tracePostExecute {foo 1} 0 leave
tracePostExecute2 {foo 1} 0 leave
}
test trace-25.7 {order dependencies of two leavestep traces} {
set info {}
trace add execution foo leavestep [list tracePostExecute tracePostExecute]
trace add execution foo leavestep [list tracePostExecute2 tracePostExecute2]
catch {foo 1} err
trace remove execution foo leavestep [list tracePostExecute tracePostExecute]
trace remove execution foo leavestep [list tracePostExecute2 tracePostExecute2]
join [list $err [join $info \n] [trace info execution foo]] "\n"
} {1
tracePostExecute {set b 1} 0 leavestep
tracePostExecute2 {set b 1} 0 leavestep
}
proc foo {a} {
set b $a
}
proc traceDelete {cmd args} {
rename $cmd {}
global info
set info $args
}
test trace-25.8 {delete command during enter leave and enter/leave-step traces} {
set info {}
trace add execution foo enter [list traceDelete foo]
trace add execution foo leave [list traceDelete foo]
trace add execution foo enterstep [list traceDelete foo]
trace add execution foo leavestep [list traceDelete foo]
catch {foo 1} err
list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
proc foo {a} {
set b $a
}
test trace-25.9 {delete command during enter leave and leavestep traces} {
set info {}
trace add execution foo enter [list traceDelete foo]
trace add execution foo leave [list traceDelete foo]
trace add execution foo leavestep [list traceDelete foo]
catch {foo 1} err
list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
proc foo {a} {
set b $a
}
test trace-25.10 {delete command during leave and leavestep traces} {
set info {}
trace add execution foo leave [list traceDelete foo]
trace add execution foo leavestep [list traceDelete foo]
catch {foo 1} err
list $err $info [trace info execution foo]
} {1 {{set b 1} 0 1 leavestep} {unknown command "foo"}}
proc foo {a} {
set b $a
}
test trace-25.11 {delete command during enter and enterstep traces} {
set info {}
trace add execution foo enter [list traceDelete foo]
trace add execution foo enterstep [list traceDelete foo]
catch {foo 1} err
list $err $info [trace info execution foo]
} {{invalid command name "foo"} {{foo 1} enter} {unknown command "foo"}}
test trace-26.1 {trace targetCmd when invoked through an alias} {
proc foo {args} {
set b $args
}
set info {}
trace add execution foo enter [list traceExecute foo]
interp alias {} bar {} foo 1
bar 2
trace remove execution foo enter [list traceExecute foo]
set info
} {{foo {foo 1 2} enter}}
test trace-26.2 {trace targetCmd when invoked through an alias} {
proc foo {args} {
set b $args
}
set info {}
trace add execution foo enter [list traceExecute foo]
interp create child
interp alias child bar {} foo 1
child eval bar 2
interp delete child
trace remove execution foo enter [list traceExecute foo]
set info
} {{foo {foo 1 2} enter}}
# 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 {}}
# 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 20 21 22 23 24 25 26 27 28 29 |
# 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.12.8.1 2002/08/20 20:25:29 das 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
# it is assumed [temporaryDirectory] is.
set oldcwd [pwd]
cd [temporaryDirectory]
# 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}
|
| ︙ | ︙ | |||
53 54 55 56 57 58 59 |
}
}
}
test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} {
cleanup
file mkdir td1/td2/td3
| | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
}
}
}
test unixFCmd-1.1 {TclpRenameFile: EACCES} {unixOnly notRoot} {
cleanup
file mkdir td1/td2/td3
file attributes td1/td2 -permissions 0000
set msg [list [catch {file rename td1/td2/td3 td2} msg] $msg]
file attributes td1/td2 -permissions 0755
set msg
} {1 {error renaming "td1/td2/td3": permission denied}}
test unixFCmd-1.2 {TclpRenameFile: EEXIST} {unixOnly notRoot} {
cleanup
file mkdir td1/td2
file mkdir td2
list [catch {file rename td2 td1} msg] $msg
|
| ︙ | ︙ | |||
114 115 116 117 118 119 120 |
set line [read $pipe 1]
catch {close $pipe}
list $line [testgotsig]
} {h 1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \
{unixOnly notRoot} {
cleanup
| | | > > > > > > > > | > | > | 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 |
set line [read $pipe 1]
catch {close $pipe}
list $line [testgotsig]
} {h 1}
test unixFCmd-2.1 {TclpCopyFile: target exists: lstat(dst) == 0} \
{unixOnly notRoot} {
cleanup
close [open tf1 a]
close [open tf2 a]
file copy -force tf1 tf2
} {}
test unixFCmd-2.2.1 {TclpCopyFile: src is symlink} {unixOnly notRoot dontCopyLinks} {
# copying links should end up with real files
cleanup
close [open tf1 a]
file link -symbolic tf2 tf1
file copy tf2 tf3
file type tf3
} {file}
test unixFCmd-2.2.2 {TclpCopyFile: src is symlink} {unixOnly notRoot} {
# copying links should end up with the links copied
cleanup
close [open tf1 a]
file link -symbolic tf2 tf1
file copy tf2 tf3
file type tf3
} {link}
test unixFCmd-2.3 {TclpCopyFile: src is block} {unixOnly notRoot} {
cleanup
set null "/dev/null"
while {[file type $null] != "characterSpecial"} {
|
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
} else {
file copy tf1 tf2
expr {"[file type tf1]" == "[file type tf2]"}
}
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} {
cleanup
| | | > | < | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
} else {
file copy tf1 tf2
expr {"[file type tf1]" == "[file type tf2]"}
}
} {1}
test unixFCmd-2.5 {TclpCopyFile: copy attributes} {unixOnly notRoot} {
cleanup
close [open tf1 a]
file attributes tf1 -permissions 0472
file copy tf1 tf2
file attributes tf2 -permissions
} 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
test unixFCmd-3.1 {CopyFile not done} {emptyTest unixOnly notRoot} {
} {}
test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unixOnly notRoot} {
} {}
|
| ︙ | ︙ | |||
273 274 275 276 277 278 279 |
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
| | | < < | | | | | | | | | | | > < < < < < < < < < < < < | 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 |
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.4 rwxrwxrwx 00777
permcheck unixFCmd-17.5 r--r---w- 00442
permcheck unixFCmd-17.6 0 00000
permcheck unixFCmd-17.7 u+rwx,g+r 00740
permcheck unixFCmd-17.8 u-w 00540
permcheck unixFCmd-17.9 o+rwx 00547
permcheck unixFCmd-17.10 --x--x--x 00111
permcheck unixFCmd-17.11 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
file mkdir $nd
cd $nd
file attributes $nd -permissions 0000
set r [list [catch {pwd} res] [string range $res 0 36]];
cd $cd;
file attributes $nd -permissions 0755
file delete $nd
set r
} {1 {error getting working directory name:}}
# cleanup
cleanup
cd $oldcwd
::tcltest::cleanupTests
return
|
Changes to tests/unixFile.test.
1 2 3 4 5 6 7 8 9 10 11 | # This file contains tests for the routines in the file tclUnixFile.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) 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 |
# This file contains tests for the routines in the file tclUnixFile.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) 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: unixFile.test,v 1.6.18.1 2002/08/20 20:25:29 das 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 \"testfindexecutable\""
puts "command, so I can't test the Tcl_FindExecutable function"
::tcltest::cleanupTests
return
}
set oldpwd [pwd]
cd [temporaryDirectory]
catch {
set oldPath $env(PATH)
file attributes [makeFile "" junk] -perm 0777
}
set absPath [file join [temporaryDirectory] junk]
test unixFile-1.1 {Tcl_FindExecutable} {unixOnly} {
set env(PATH) ""
testfindexecutable junk
} $absPath
test unixFile-1.2 {Tcl_FindExecutable} {unixOnly} {
set env(PATH) "/dummy"
|
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
test unixFile-1.7 {Tcl_FindExecutable} {unixOnly} {
set env(PATH) ":/dummy"
testfindexecutable junk
} $absPath
# cleanup
catch {set env(PATH) $oldPath}
| | > < < < < < < < < < < < < | 59 60 61 62 63 64 65 66 67 68 69 |
test unixFile-1.7 {Tcl_FindExecutable} {unixOnly} {
set env(PATH) ":/dummy"
testfindexecutable junk
} $absPath
# cleanup
catch {set env(PATH) $oldPath}
removeFile junk
cd $oldpwd
::tcltest::cleanupTests
return
|
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 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 |
# 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.25.2.2 2002/08/20 20:25:29 das Exp $
package require tcltest 2
namespace import -force ::tcltest::*
if {[info exists env(TCL_LIBRARY)]} {
set oldlibrary $env(TCL_LIBRARY)
unset env(TCL_LIBRARY)
}
catch {set oldlang $env(LANG)}
set env(LANG) C
test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly stdio} {
set x {}
# Watch out for a race condition here. If tcltest is too slow to start
# then we'll kill it before it has a chance to set up its signal handler.
set f [open "|[list [interpreter]]" w+]
puts $f "puts hi"
flush $f
gets $f
exec kill -PIPE [pid $f]
lappend x [catch {close $f}]
set f [open "|[list [interpreter]]" w+]
puts $f "puts hi"
flush $f
gets $f
exec kill [pid $f]
lappend x [catch {close $f}]
set x
} {0 1}
# This test is really a test of code in tclUnixChan.c, but the
# channels are set up as part of initialisation of the interpreter so
# the test seems to me to fit here as well as anywhere else.
test unixInit-1.2 {initialisation: standard channel type deduction} {unixOnly stdio} {
# pipe1 is a connection to a server that reports what port it
# starts on, and delivers a constant string to the first client to
# connect to that port before exiting.
set pipe1 [open "|[list [interpreter]]" r+]
puts $pipe1 {
proc accept {channel host port} {
puts $channel {puts [fconfigure stdin -peername]; exit}
close $channel
exit
}
puts [fconfigure [socket -server accept 0] -sockname]
vwait forever \
}
# Note the backslash above; this is important to make sure that the
# whole string is read before an [exit] can happen...
flush $pipe1
set port [lindex [gets $pipe1] 2]
set sock [socket localhost $port]
# pipe2 is a connection to a Tcl interpreter that takes its orders
# from the socket we hand it (i.e. the server we create above.)
# These orders will tell it to print out the details about the
# socket it is taking instructions from, hopefully identifying it
# as a socket. Which is what this test is all about.
set pipe2 [open "|[list [interpreter] <@$sock]" r]
set result [gets $pipe2]
# Clear any pending data; stops certain kinds of (non-important) errors
fconfigure $pipe1 -blocking 0; gets $pipe1
fconfigure $pipe2 -blocking 0; gets $pipe2
# Close the pipes and the socket.
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
} then {
subst "OK"
} else {
subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
}
} {OK}
| | < | | | | | | | > | | > | | | | | > > > > > | > | > > > > > > > > > | | | 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 |
} then {
subst "OK"
} else {
subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'"
}
} {OK}
proc getlibpath [list [list program [interpreter]]] {
set f [open "|[list $program]" w+]
fconfigure $f -buffering none
puts $f {puts $tcl_libPath; exit}
set path [gets $f]
close $f
return $path
}
# Some tests require the testgetdefenc command
testConstraint testgetdefenc [llength [info commands testgetdefenc]]
test unixInit-2.0 {TclpInitLibraryPath: setting tclDefaultEncodingDir} \
{unixOnly testgetdefenc} {
set origDir [testgetdefenc]
testsetdefenc slappy
set path [testgetdefenc]
testsetdefenc $origDir
set path
} {slappy}
test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} \
{unixOnly stdio} {
set path [getlibpath]
set installLib lib/tcl[info tclversion]
set developLib tcl[info patchlevel]/library
set prefix [file dirname [file dirname [interpreter]]]
set x {}
lappend x [string compare [lindex $path 0] $prefix/$installLib]
lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib]
set x
} {0 0}
test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} {unixOnly stdio} {
# ((str != NULL) && (str[0] != '\0'))
set env(TCL_LIBRARY) sparkly
set path [getlibpath]
unset env(TCL_LIBRARY)
lindex $path 0
} "sparkly"
test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} \
{unixOnly stdio} {
# ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))
set env(TCL_LIBRARY) /a/b/tcl1.7
set path [getlibpath]
unset env(TCL_LIBRARY)
lrange $path 0 1
} [list /a/b/tcl1.7 /a/b/tcl[info tclversion]]
test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} \
{unixOnly stdio} {
# Child process translates env variable from native encoding.
set env(TCL_LIBRARY) "\xa7"
set x [lindex [getlibpath] 0]
unset env(TCL_LIBRARY)
unset env(LANG)
set x
} "\xa7"
test unixInit-2.5 {TclpInitLibraryPath: compiled-in library path} \
{emptyTest unixOnly} {
# cannot test
} {}
test unixInit-2.6 {TclpInitLibraryPath: executable relative} \
{unixOnly stdio} {
makeDirectory tmp
makeDirectory [file join tmp sparkly]
makeDirectory [file join tmp sparkly bin]
file copy [interpreter] [file join [temporaryDirectory] tmp sparkly \
bin tcltest]
makeDirectory [file join tmp sparkly lib]
makeDirectory [file join tmp sparkly lib tcl[info tclversion]]
makeFile {} [file join tmp sparkly lib tcl[info tclversion] init.tcl]
set x [lrange [getlibpath [file join [temporaryDirectory] tmp sparkly \
bin tcltest]] 0 1]
removeFile [file join tmp sparkly lib tcl[info tclversion] init.tcl]
removeDirectory [file join tmp sparkly lib tcl[info tclversion]]
removeDirectory [file join tmp sparkly lib]
removeDirectory [file join tmp sparkly bin]
removeDirectory [file join tmp sparkly]
removeDirectory tmp
set x
} [list [temporaryDirectory]/tmp/sparkly/lib/tcl[info tclversion] [temporaryDirectory]/tmp/lib/tcl[info tclversion]]
test unixInit-2.7 {TclpInitLibraryPath: compiled-in library path} \
{emptyTest unixOnly} {
# would need test command to get defaultLibDir and compare it to
# [lindex $auto_path end]
} {}
#
# The following two tests write to the directory /tmp/sparkly instead
# of to [temporaryDirectory]. This is because the failures tested by
# these tests need paths near the "root" of the file system to present
# themselves.
#
testConstraint noSparkly [expr {![file exists [file join /tmp sparkly]]}]
testConstraint noTmpInstall [expr {![file exists \
[file join /tmp lib tcl[info tclversion]]]}]
test unixInit-2.8 {TclpInitLibraryPath: all absolute pathtype} {unix noSparkly noTmpInstall} {
# Checking for Bug 219416
# When a program that embeds the Tcl library, like tcltest, is
# installed near the "root" of the file system, there was a problem
# constructing directories relative to the executable. When a
# relative ".." went past the root, relative path names were created
# rather than absolute pathnames. In some cases, accessing past the
# root caused memory access violations too.
#
# The bug is now fixed, but here we check for it by making sure that
# the directories constructed relative to the executable are all
# absolute pathnames, even when the executable is installed near
# the root of the filesystem.
#
# The only directory near the root we are likely to have write access
# to is /tmp.
file delete -force /tmp/sparkly
file delete -force /tmp/lib/tcl[info tclversion]
file mkdir /tmp/sparkly
file copy [interpreter] /tmp/sparkly/tcltest
# Keep any existing /tmp/lib directory
set deletelib 1
if {[file exists /tmp/lib]} {
if {[file isdirectory /tmp/lib]} {
set deletelib 0
} else {
|
| ︙ | ︙ | |||
244 245 246 247 248 249 250 |
# Clean up temporary installation
file delete -force /tmp/sparkly
file delete -force /tmp/lib/tcl[info tclversion]
if {$deletelib} {file delete -force /tmp/lib}
set allAbsolute
} 1
| > | < | | > > | | | | | 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 |
# Clean up temporary installation
file delete -force /tmp/sparkly
file delete -force /tmp/lib/tcl[info tclversion]
if {$deletelib} {file delete -force /tmp/lib}
set allAbsolute
} 1
testConstraint noTmpBuild [expr {![file exists [file join /tmp library]]}]
test unixInit-2.9 {TclpInitLibraryPath: paths relative to executable} {unix noSparkly noTmpBuild} {
# Checking for Bug 438014
file delete -force /tmp/sparkly
file delete -force /tmp/library
file mkdir /tmp/sparkly
file copy [interpreter] /tmp/sparkly/tcltest
file mkdir /tmp/library/
close [open /tmp/library/init.tcl w]
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
} -match regexp -result ^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
puts $f {puts [encoding system]; exit}
set enc [gets $f]
close $f
unset env(LANG)
unset env(LC_ALL)
catch {set env(LC_ALL) $oldlc_all}
|
| ︙ | ︙ |
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 |
# 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.9.18.1 2002/08/20 20:25:29 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
|
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
# 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} {unixOnly && !testthread} {
catch {vwait x}
| | | | | | | | < < < < < < < < < < < < < < < | 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 |
# 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} {unixOnly && !testthread} {
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
} {1 {can't wait for variable "x": would wait forever}}
test unixNotfy-1.2 {Tcl_DeleteFileHandler} {unixOnly && !testthread} {
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
close $f1
vwait y
close $f2
list [catch {vwait x} msg] $msg
} {1 {can't wait for variable "x": would wait forever}}
test unixNotfy-2.1 {Tcl_DeleteFileHandler} {unixOnly testthread} {
update
set f [open [makeFile "" foo] w]
fileevent $f writable {set x 1}
vwait x
close $f
testthread create "after 500
testthread send [testthread id] {set x ok}
testthread exit"
vwait x
set x
} {ok}
test unixNotfy-2.2 {Tcl_DeleteFileHandler} {unixOnly testthread} {
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 "after 500
testthread send [testthread id] {set x ok}
testthread exit"
vwait x
set x
} {ok}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/uplevel.test.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # Commands covered: uplevel # # 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: uplevel
#
# 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: uplevel.test,v 1.6.18.1 2002/08/20 20:25:29 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
proc a {x y} {
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
global x y
set x [info level]
set y [info level 1]
}
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3
# cleanup
::tcltest::cleanupTests
return
| > > > > > > > > > > > > > > > | 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 |
global x y
set x [info level]
set y [info level 1]
}
a2
test uplevel-5.1 {info level} {set x} 1
test uplevel-5.2 {info level} {set y} a3
namespace eval ns1 {
proc set args {return ::ns1}
}
proc a2 {} {
uplevel {set x ::}
}
test uplevel-6.1 {uplevel and shadowed cmds} {
set res [namespace eval ns1 a2]
lappend res [namespace eval ns2 a2]
lappend res [namespace eval ns1 a2]
namespace eval ns1 {rename set {}}
lappend res [namespace eval ns1 a2]
} {::ns1 :: ::ns1 ::}
# 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.17.8.2 2002/08/20 20:25:29 das Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
upvar #0 aaaaa xxxxx
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
| | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
upvar #0 aaaaa xxxxx
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
|
| ︙ | ︙ |
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.11.8.1 2002/08/20 20:25:29 das Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
if {$tcl_platform(platform) == "windows"} {
|
| ︙ | ︙ | |||
55 56 57 58 59 60 61 |
puts ready
vwait done
update
exit
}
close $f
| | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
puts ready
vwait done
update
exit
}
close $f
set f [open |[list [interpreter] $::scriptName] r]
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}
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
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"
| | | | | | 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 |
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} {
set a ""
set child [createChildProcess child]
dde execute TclEval child {set a "foo"}
dde execute TclEval child {set done 1}
set a
} ""
test winDde-4.2 {DDE execute remotely} {stdio pcOnly} {
set a ""
set child [createChildProcess child]
dde execute -async TclEval child {set a "foo"}
dde execute TclEval child {set done 1}
set a
} ""
test winDde-4.3 {DDE request locally} {stdio pcOnly} {
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
} foo
test winDde-4.4 {DDE eval locally} {stdio pcOnly} {
set a ""
set child [createChildProcess child]
set a [dde eval child set a "foo"]
dde execute TclEval child {set done 1}
set a
} foo
|
| ︙ | ︙ |
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.14.4.3 2002/08/20 20:25:29 das Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
|
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
}
}
}
if {[string equal $tcl_platform(platform) "windows"]} {
if {[string equal $tcl_platform(os) "Windows NT"] \
&& [string equal [string index $tcl_platform(osVersion) 0] "5"]} {
| | | | | | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
}
}
}
if {[string equal $tcl_platform(platform) "windows"]} {
if {[string equal $tcl_platform(os) "Windows NT"] \
&& [string equal [string index $tcl_platform(osVersion) 0] "5"]} {
tcltest::testConstraint win2000orXP 1
tcltest::testConstraint winOlderThan2000 0
} else {
tcltest::testConstraint win2000orXP 0
tcltest::testConstraint winOlderThan2000 1
}
} else {
tcltest::testConstraint win2000orXP 0
tcltest::testConstraint winOlderThan2000 0
}
set ::tcltest::testConstraints(cdrom) 0
set ::tcltest::testConstraints(exdev) 0
# find a CD-ROM so we can test read-only filesystems.
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
cleanup
createfile tf1
set fd [open tf2 w]
set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
close $fd
set msg
} {1 EACCES}
| | | | | | | | | 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 |
cleanup
createfile tf1
set fd [open tf2 w]
set msg [list [catch {testfile mv tf1 tf2} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-1.13 {TclpRenameFile: errno: EACCES} {pcOnly win2000orXP} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-1.13.1 {TclpRenameFile: errno: EACCES} {pcOnly winOlderThan2000} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.14 {TclpRenameFile: errno: EACCES} {pcOnly 95} {
cleanup
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
} {1 EACCES}
test winFCmd-1.15 {TclpRenameFile: errno: EEXIST} {pcOnly nt} {
cleanup
createfile tf1
list [catch {testfile mv tf1 nul} msg] $msg
} {1 EEXIST}
test winFCmd-1.16 {TclpRenameFile: MoveFile() != FALSE} {pcOnly} {
cleanup
createfile tf1 tf1
testfile mv tf1 tf2
list [file exists tf1] [contents tf2]
} {0 tf1}
test winFCmd-1.17 {TclpRenameFile: MoveFile() == FALSE} {pcOnly} {
cleanup
list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.18 {TclpRenameFile: srcAttr == -1} {pcOnly} {
cleanup
list [catch {testfile mv tf1 tf2} msg] $msg
} {1 ENOENT}
test winFCmd-1.19 {TclpRenameFile: errno == EACCES} {pcOnly win2000orXP} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-1.19.1 {TclpRenameFile: errno == EACCES} {pcOnly winOlderThan2000} {
cleanup
list [catch {testfile mv nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.20 {TclpRenameFile: src is dir} {pcOnly nt} {
# under 95, this would actually succeed and move the current dir out from
# under the current process!
cleanup
file delete /tf1
list [catch {testfile mv [pwd] /tf1} msg] $msg
} {1 EACCES}
test winFCmd-1.21 {TclpRenameFile: long src} {pcOnly} {
|
| ︙ | ︙ | |||
371 372 373 374 375 376 377 |
list [catch {testfile cp "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {pcOnly} {
cleanup
createfile tf1
list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
| | | | | | 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 |
list [catch {testfile cp "" tf2} msg] $msg
} {1 ENOENT}
test winFCmd-2.6 {TclpCopyFile: errno: ENOENT} {pcOnly} {
cleanup
createfile tf1
list [catch {testfile cp tf1 ""} msg] $msg
} {1 ENOENT}
test winFCmd-2.7 {TclpCopyFile: errno: EACCES} {pcOnly 95} {
cleanup
createfile tf1
set fd [open tf2 w]
set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-2.8 {TclpCopyFile: errno: EACCES} {pcOnly win2000orXP} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 EINVAL}
test winFCmd-2.8.1 {TclpCopyFile: errno: EACCES} {pcOnly nt winOlderThan2000} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 EACCES}
test winFCmd-2.9 {TclpCopyFile: errno: ENOENT} {pcOnly 95} {
cleanup
list [catch {testfile cp nul tf1} msg] $msg
} {1 ENOENT}
test winFCmd-2.10 {TclpCopyFile: CopyFile succeeds} {pcOnly} {
cleanup
createfile tf1 tf1
testfile cp tf1 tf2
|
| ︙ | ︙ | |||
441 442 443 444 445 446 447 |
cleanup
createfile tf1 tf1
createfile tf2 tf2
testchmod 000 tf2
testfile cp tf1 tf2
list [file writable tf2] [contents tf2]
} {1 tf1}
| | | 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
cleanup
createfile tf1 tf1
createfile tf2 tf2
testchmod 000 tf2
testfile cp tf1 tf2
list [file writable tf2] [contents tf2]
} {1 tf1}
test winFCmd-2.18 {TclpCopyFile: still can't copy onto dst} {pcOnly 95} {
cleanup
createfile tf1
createfile tf2
testchmod 000 tf2
set fd [open tf2]
set msg [list [catch {testfile cp tf1 tf2} msg] $msg]
close $fd
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
set fd [open tf1 w]
testchmod 000 tf1
set msg [list [catch {testfile rm tf1} msg] $msg]
close $fd
set msg
} {1 EACCES}
| | | | 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
set fd [open tf1 w]
testchmod 000 tf1
set msg [list [catch {testfile rm tf1} msg] $msg]
close $fd
set msg
} {1 EACCES}
test winFCmd-4.1 {TclpCreateDirectory: errno: EACCES} {pcOnly nt cdrom} {
list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 EACCES}
test winFCmd-4.2 {TclpCreateDirectory: errno: EACCES} {pcOnly 95 cdrom} {
list [catch {testfile mkdir $cdrom/dummy~~.dir} msg] $msg
} {1 ENOSPC}
test winFCmd-4.3 {TclpCreateDirectory: errno: EEXIST} {pcOnly} {
cleanup
file mkdir td1
list [catch {testfile mkdir td1} msg] $msg
} {1 EEXIST}
|
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {pcOnly} {
cleanup
file mkdir td1
testchmod 000 td1
testfile rmdir td1
file exists td1
} {0}
| | | | | | 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 |
test winFCmd-6.9 {TclpRemoveDirectory: errno == EACCES} {pcOnly} {
cleanup
file mkdir td1
testchmod 000 td1
testfile rmdir td1
file exists td1
} {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
list [catch {testfile rmdir /} msg] $msg
} {1 {/ EACCES}}
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
file mkdir td1
testchmod 000 td1
testfile rmdir td1
file exists td1
} {0}
test winFCmd-6.14 {TclpRemoveDirectory: check if empty dir} {pcOnly 95} {
cleanup
file mkdir td1/td2
list [catch {testfile rmdir td1} msg] $msg
} {1 {td1 EEXIST}}
test winFCmd-6.15 {TclpRemoveDirectory: !recursive} {pcOnly} {
cleanup
file mkdir td1/td2
|
| ︙ | ︙ | |||
674 675 676 677 678 679 680 |
test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
| | | | 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
test winFCmd-7.7 {TraverseWinTree: append \ to source if necessary} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
test winFCmd-7.8 {TraverseWinTree: append \ to source if necessary} {pcOnly 95 cdrom} {
# cdrom can return either d:\ or D:/, but we only care about the errcode
list [catch {testfile rmdir $cdrom/} msg] [lindex $msg 1]
} {1 EEXIST}
test winFCmd-7.9 {TraverseWinTree: append \ to source if necessary} {pcOnly nt cdrom} {
list [catch {testfile rmdir $cdrom/} msg] [lindex $msg 1]
} {1 EACCES}
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} {
|
| ︙ | ︙ | |||
707 708 709 710 711 712 713 |
test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
| | | | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 |
test winFCmd-7.13 {TraverseWinTree: append \ to target if necessary} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1 tf1
testfile cpdir td1 td2
contents td2/tf1
} {tf1}
test winFCmd-7.14 {TraverseWinTree: append \ to target if necessary} {pcOnly 95} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 /} msg] $msg
} {1 {/ EEXIST}}
test winFCmd-7.15 {TraverseWinTree: append \ to target if necessary} {pcOnly nt} {
cleanup
file mkdir td1
list [catch {testfile cpdir td1 /} msg] $msg
} {1 {/ EACCES}}
test winFCmd-7.16 {TraverseWinTree: recurse on files: no files} {pcOnly} {
cleanup
file mkdir td1
|
| ︙ | ︙ | |||
786 787 788 789 790 791 792 |
test winFCmd-9.1 {TraversalDelete: DOTREE_F} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1
testfile rmdir -force td1
} {}
| | | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 |
test winFCmd-9.1 {TraversalDelete: DOTREE_F} {pcOnly} {
cleanup
file mkdir td1
createfile td1/tf1
testfile rmdir -force td1
} {}
test winFCmd-9.2 {TraversalDelete: DOTREE_F} {pcOnly 95} {
cleanup
file mkdir td1
set fd [open td1/tf1 w]
set msg [list [catch {testfile rmdir -force td1} msg] $msg]
close $fd
set msg
} {1 {td1\tf1 EACCES}}
|
| ︙ | ︙ |
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 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 |
# 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.6.18.2 2002/08/20 20:25:29 das 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.2 {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.3 {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
set result
} {GlobCapS GlobCapS}
test winFile-2.2 {TclpMatchFiles: case sensitivity} {pcOnly} {
makeFile {} globlower
set result [list [glob -nocomplain globl*] [glob -nocomplain gLOBl*]]
removeFile globlower
set result
} {globlower globlower}
test winFile-3.1 {file system} {pcOnly} {
set res "volume types ok"
foreach vol [file volumes] {
# Have to catch in case there is a removable drive (CDROM, floppy)
# with nothing in it.
catch {
if {![string equal [lindex [file system $vol] 1] [testvolumetype $vol]]} {
set res "For $vol, we found [file system $vol]\
and [testvolumetype $vol] are different"
break
}
}
}
set res
} {volume types ok}
# cleanup
::tcltest::cleanupTests
|
| ︙ | ︙ |
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 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 |
#
# 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.15.4.2 2002/08/20 20:25:29 das Exp $
package require tcltest
namespace import -force ::tcltest::*
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]
if {[catch {puts console1 ""}]} {
set ::tcltest::testConstraints(AllocConsole) 1
} else {
set ::tcltest::testConstraints(.console) 1
}
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
append big $big
append big $big
append big $big
append big $big
append big $big
append big $big
set path(little) [makeFile {} little]
set f [open $path(little) w]
puts -nonewline $f "little"
close $f
set path(big) [makeFile {} big]
set f [open $path(big) w]
puts -nonewline $f $big
close $f
proc contents {file} {
set f [open $file r]
set r [read $f]
close $f
set r
}
set path(more) [makeFile {
while {[eof stdin] == 0} {
puts -nonewline [read stdin]
}
} more]
set path(stdout) [makeFile {} stdout]
set path(stderr) [makeFile {} stderr]
test winpipe-1.1 {32 bit comprehensive tests: from little file} {pcOnly exec cat32} {
exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.2 {32 bit comprehensive tests: from big file} {pcOnly exec cat32} {
exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {pcOnly nt exec cat32} {
exec [interpreter] more < little | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {pcOnly nt exec cat32} {
exec [interpreter] more < big | $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {pcOnly 95 exec cat32} {
exec command /c type big |& $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.6 {32 bit comprehensive tests: from console} \
{pcOnly cat32 AllocConsole} {
# would block waiting for human input
} {}
test winpipe-1.7 {32 bit comprehensive tests: from NUL} {pcOnly exec cat32} {
exec $cat32 < nul > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {{} stderr32}
test winpipe-1.8 {32 bit comprehensive tests: from socket} {pcOnly cat32} {
# doesn't work
} {}
test winpipe-1.9 {32 bit comprehensive tests: from nowhere} \
{pcOnly exec cat32 .console} {
exec $cat32 > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {{} stderr32}
test winpipe-1.10 {32 bit comprehensive tests: from file handle} \
{pcOnly exec cat32} {
set f [open $path(little) r]
exec $cat32 <@$f > $path(stdout) 2> $path(stderr)
close $f
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.11 {32 bit comprehensive tests: read from application} \
{pcOnly exec cat32} {
set f [open "|[list $cat32] < $path(little)" r]
gets $f line
catch {close $f} msg
list $line $msg
} {little stderr32}
test winpipe-1.12 {32 bit comprehensive tests: a little to file} \
{pcOnly exec cat32} {
exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.13 {32 bit comprehensive tests: a lot to file} \
{pcOnly exec cat32} {
exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.14 {32 bit comprehensive tests: a little to pipe} \
{pcOnly exec stdio cat32} {
exec $cat32 < $path(little) | [interpreter] $path(more) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.15 {32 bit comprehensive tests: a lot to pipe} \
{pcOnly exec stdio cat32} {
exec $cat32 < $path(big) | [interpreter] $path(more) > $path(stdout) 2> $path(stderr)
list [contents $path(stdout)] [contents $path(stderr)]
} "{$big} stderr32"
test winpipe-1.16 {32 bit comprehensive tests: to console} {pcOnly exec cat32} {
catch {exec $cat32 << "You should see this\n" >@stdout} msg
set msg
} stderr32
test winpipe-1.17 {32 bit comprehensive tests: to NUL} {pcOnly exec cat32} {
# some apps hang when sending a large amount to NUL. $cat32 isn't one.
catch {exec $cat32 < $path(big) > nul} msg
set msg
} stderr32
test winpipe-1.18 {32 bit comprehensive tests: to nowhere} \
{pcOnly exec cat32 .console} {
exec $cat32 < $path(big) >&@stdout
} {}
test winpipe-1.19 {32 bit comprehensive tests: to file handle} {pcOnly exec cat32} {
set f1 [open $path(stdout) w]
set f2 [open $path(stderr) w]
exec $cat32 < $path(little) >@$f1 2>@$f2
close $f1
close $f2
list [contents $path(stdout)] [contents $path(stderr)]
} {little stderr32}
test winpipe-1.20 {32 bit comprehensive tests: write to application} \
{pcOnly exec cat32} {
set f [open |[list $cat32 >$path(stdout)] w]
puts -nonewline $f "foo"
catch {close $f} msg
list [contents $path(stdout)] $msg
} {foo stderr32}
test winpipe-1.21 {32 bit comprehensive tests: read/write application} \
{pcOnly exec cat32} {
set f [open "|[list $cat32]" r+]
puts $f $big
puts $f \032
flush $f
set r [read $f 64]
catch {close $f}
set r
} "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
test winpipe-1.22 {Checking command.com for Win95/98 hanging} {pcOnly 95 exec} {
exec command.com /c dir /b
set result 1
} 1
file delete more
test winpipe-4.1 {Tcl_WaitPid} {pcOnly nt exec cat32} {
proc readResults {f} {
global x result
if { [eof $f] } {
close $f
set x 1
} else {
set line [read $f ]
set result "$result$line"
}
}
set f [open "|[list $cat32] < big 2> $path(stderr)" r]
fconfigure $f -buffering none -blocking 0
fileevent $f readable "readResults $f"
set x 0
set result ""
vwait x
list $result $x [contents $path(stderr)]
} "{$big} 1 stderr32"
set path(nothing) [makeFile {} nothing]
close [open $path(nothing) w]
catch {set env_tmp $env(TMP)}
catch {set env_temp $env(TEMP)}
set env(TMP) c:/
set env(TEMP) c:/
test winpipe-5.1 {TclpCreateTempFile: cleanup temp files} {pcOnly exec} {
set x {}
set existing [glob -nocomplain c:/tcl*.tmp]
exec [interpreter] < nothing
foreach p [glob -nocomplain c:/tcl*.tmp] {
if {[lsearch $existing $p] == -1} {
lappend x $p
}
}
set x
} {}
test winpipe-5.2 {TclpCreateTempFile: TMP and TEMP not defined} {pcOnly exec} {
set tmp $env(TMP)
set temp $env(TEMP)
unset env(TMP)
unset env(TEMP)
exec [interpreter] < nothing
set env(TMP) $tmp
set env(TEMP) $temp
set x {}
} {}
test winpipe-5.3 {TclpCreateTempFile: TMP specifies non-existent directory} \
{pcOnly exec } {
set tmp $env(TMP)
set env(TMP) snarky
exec [interpreter] < nothing
set env(TMP) $tmp
set x {}
} {}
test winpipe-5.4 {TclpCreateTempFile: TEMP specifies non-existent directory} \
{pcOnly exec} {
set tmp $env(TMP)
set temp $env(TEMP)
unset env(TMP)
set env(TEMP) snarky
exec [interpreter] < nothing
set env(TMP) $tmp
set env(TEMP) $temp
set x {}
} {}
test winpipe-6.1 {PipeSetupProc & PipeCheckProc: read threads} \
{pcOnly exec cat32} {
set f [open "|[list $cat32]" r+]
fconfigure $f -blocking 0
fileevent $f writable { set x writable }
set x {}
vwait x
fileevent $f writable {}
fileevent $f readable { lappend x readable }
after 100 { lappend x timeout }
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
fileevent $f writable { set x writable }
set x {}
vwait x
puts -nonewline $f $big$big$big$big
flush $f
after 100 { lappend x timeout }
vwait x
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
} [list $path(echoArgs.tcl) {foo {} bar}]
test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly exec} {
exec [interpreter] $path(echoArgs.tcl) foo \" bar
} [list $path(echoArgs.tcl) {foo {"} 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 tools/genStubs.tcl.
1 2 3 4 5 6 7 8 9 10 | # genStubs.tcl -- # # This script generates a set of stub files for a given # interface. # # # 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 |
# genStubs.tcl --
#
# This script generates a set of stub files for a given
# interface.
#
#
# 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: genStubs.tcl,v 1.9.8.4 2002/08/20 20:25:29 das Exp $
package require Tcl 8
namespace eval genStubs {
# libraryName --
#
# The name of the entire library. This value is used to compute
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 | # # This function is used in the declarations file to declare a new # interface entry. # # Arguments: # index The index number of the interface. # platform The platform the interface belongs to. Should be one | | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
#
# This function is used in the declarations file to declare a new
# interface entry.
#
# Arguments:
# index The index number of the interface.
# platform The platform the interface belongs to. Should be one
# of generic, win, unix, or mac, or macosx or aqua or x11.
# decl The C function declaration, or {} for an undefined
# entry.
#
# Results:
# None.
proc genStubs::declare {args} {
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 |
proc genStubs::addPlatformGuard {plat text} {
switch $plat {
win {
return "#ifdef __WIN32__\n${text}#endif /* __WIN32__ */\n"
}
unix {
| | | > > > | 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 |
proc genStubs::addPlatformGuard {plat text} {
switch $plat {
win {
return "#ifdef __WIN32__\n${text}#endif /* __WIN32__ */\n"
}
unix {
return "#if !defined(__WIN32__) && !defined(MAC_TCL) /* UNIX */\n${text}#endif /* UNIX */\n"
}
mac {
return "#ifdef MAC_TCL\n${text}#endif /* MAC_TCL */\n"
}
macosx {
return "#ifdef MAC_OSX_TCL\n${text}#endif /* MAC_OSX_TCL */\n"
}
aqua {
return "#ifdef MAC_OSX_TK\n${text}#endif /* MAC_OSX_TK */\n"
}
x11 {
return "#if !(defined(__WIN32__) || defined(MAC_TCL) || defined(MAC_OSX_TK)) /* X11 */\n${text}#endif /* X11 */\n"
}
}
return "$text"
}
# genStubs::emitSlots --
#
# Generate the stub table slots for the given interface. If there
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 |
set emit 1
} elseif {$onAll} {
append text [eval {addPlatformGuard $plat} $skipString]
set emit 1
}
}
#
| > | | > > > > > > > | 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 |
set emit 1
} elseif {$onAll} {
append text [eval {addPlatformGuard $plat} $skipString]
set emit 1
}
}
#
# "aqua" and "macosx" and "x11" are special cases,
# since "macosx" always implies "unix" and "aqua",
# "macosx", so we need to be careful not to
# emit duplicate stubs entries for the two.
#
if {[info exists stubs($name,aqua,$i)]
&& ![info exists stubs($name,macosx,$i)]} {
append text [addPlatformGuard aqua \
[$slotProc $name $stubs($name,aqua,$i) $i]]
set emit 1
}
if {[info exists stubs($name,macosx,$i)]
&& ![info exists stubs($name,unix,$i)]} {
append text [addPlatformGuard macosx \
[$slotProc $name $stubs($name,macosx,$i) $i]]
set emit 1
}
if {[info exists stubs($name,x11,$i)]
&& ![info exists stubs($name,unix,$i)]} {
append text [addPlatformGuard x11 \
[$slotProc $name $stubs($name,x11,$i) $i]]
set emit 1
}
}
if {$emit == 0} {
eval {append text} $skipString
}
}
} else {
# Emit separate stubs blocks per platform
foreach plat {unix win mac} {
if {[info exists stubs($name,$plat,lastNum)]} {
set lastNum $stubs($name,$plat,lastNum)
set temp {}
for {set i 0} {$i <= $lastNum} {incr i} {
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 |
eval {append temp} $skipString
} else {
append temp [$slotProc $name $stubs($name,macosx,$i) $i]
}
}
append text [addPlatformGuard macosx $temp]
}
| > > > > > > > > > > | | > > > | 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 |
eval {append temp} $skipString
} else {
append temp [$slotProc $name $stubs($name,macosx,$i) $i]
}
}
append text [addPlatformGuard macosx $temp]
}
# Again, make sure you don't duplicate entries for x11 & unix.
if {[info exists stubs($name,x11,lastNum)]
&& ![info exists stubs($name,unix,lastNum)]} {
set lastNum $stubs($name,x11,lastNum)
set temp {}
for {set i 0} {$i <= $lastNum} {incr i} {
if {![info exists stubs($name,x11,$i)]} {
eval {append temp} $skipString
} else {
append temp [$slotProc $name $stubs($name,x11,$i) $i]
}
}
append text [addPlatformGuard x11 $temp]
}
}
}
# genStubs::emitDeclarations --
#
# This function emits the function declarations for this interface.
#
# Arguments:
|
| ︙ | ︙ |
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.7.14.3 2002/08/20 20:25:29 das Exp $ # # # PASS 1 # set man2tclprog [file join [file dirname [info script]] man2tcl.exe] |
| ︙ | ︙ | |||
112 113 114 115 116 117 118 119 |
exit 1
}
set arg 0
if {![string compare [lindex $argv $arg] "-bitmap"]} {
set bitmap [lindex $argv [incr arg]]
}
| > | | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
exit 1
}
set arg 0
if {![string compare [lindex $argv $arg] "-bitmap"]} {
set bitmap [lindex $argv [incr arg]]
incr arg
}
set baseName [lindex $argv $arg]
set version [lindex $argv [incr arg]]
set files {}
foreach i [lrange $argv [incr arg] end] {
set i [file join $i]
if {[file isdir $i]} {
foreach f [lsort [glob -directory $i "*.\[13n\]"]] {
lappend files $f
|
| ︙ | ︙ |
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.4b3 Disk Filename=setup Patch Flags=0000000000000001 Patch Threshold=85 Patch Memory=4000 Variable Name1=_SYS_ Variable Default1=C:\WINDOWS\SYSTEM Variable Flags1=00001000 |
| ︙ | ︙ | |||
1583 1584 1585 1586 1587 1588 1589 |
end
item: Install File
Source=${__TCLBASEDIR__}\library\reg\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
| | | | | | 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 |
end
item: Install File
Source=${__TCLBASEDIR__}\library\reg\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\release\tclreg10.dll
Destination=%MAINDIR%\lib\tcl%VER%\reg1.0\tclreg10.dll
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\library\dde\pkgIndex.tcl
Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\pkgIndex.tcl
Flags=0000000000000010
end
item: Install File
Source=${__TCLBASEDIR__}\win\release\tcldde12.dll
Destination=%MAINDIR%\lib\tcl%VER%\dde1.2\tcldde12.dll
Flags=0000000000000010
end
item: Install File
Source=C:\WINNT\SYSTEM32\Msvcrt.dll
Destination=%MAINDIR%\bin\msvcrt.dll
Flags=0010001000000011
end
|
| ︙ | ︙ |
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 16 17 18 19 20 | # # 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.83.6.5 2002/08/20 20:25:29 das Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ MINOR_VERSION = @TCL_MINOR_VERSION@ PATCH_LEVEL = @TCL_PATCH_LEVEL@ #---------------------------------------------------------------- # 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 # the configuration script). #---------------------------------------------------------------- |
| ︙ | ︙ | |||
133 134 135 136 137 138 139 | # To enable memory debugging reverse the comment characters on the following # lines. Warning: if you enable memory debugging, you must do it # *everywhere*, including all the code that calls Tcl, and you must use # ckalloc and ckfree everywhere instead of malloc and free. MEM_DEBUG_FLAGS = #MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG | < | > | | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
# To enable memory debugging reverse the comment characters on the following
# lines. Warning: if you enable memory debugging, you must do it
# *everywhere*, including all the code that calls Tcl, and you must use
# ckalloc and ckfree everywhere instead of malloc and free.
MEM_DEBUG_FLAGS =
#MEM_DEBUG_FLAGS = -DTCL_MEM_DEBUG
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
#TCL_STUB_LIB_FILE = libtclstub.a
# Generic stub lib name used in rules that apply to tcl and tk
STUB_LIB_FILE = ${TCL_STUB_LIB_FILE}
TCL_STUB_LIB_FLAG = @TCL_STUB_LIB_FLAG@
#TCL_STUB_LIB_FLAG = -ltclstub
# To enable compilation debugging reverse the comment characters on
# one of the following lines.
COMPILE_DEBUG_FLAGS =
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 | # 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@ | | > > | > > > > > > > > > | 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 |
# 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_FLAGS = @SHLIB_LD_FLAGS@
SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@
SHLIB_SUFFIX = @SHLIB_SUFFIX@
#SHLIB_SUFFIX =
DLTEST_TARGETS = dltest.marker
# Additional search flags needed to find the various shared libraries
# at run-time. The first symbol is for use when creating a binary
# with cc, and the second is for use when running ld directly.
CC_SEARCH_FLAGS = @CC_SEARCH_FLAGS@
LD_SEARCH_FLAGS = @LD_SEARCH_FLAGS@
# The following symbol is defined to "$(DLTEST_TARGETS)" if dynamic
# loading is available; this causes everything in the "dltest"
# subdirectory to be built when making "tcltest. If dynamic loading
# isn't available, configure defines this symbol to an empty string,
# in which case the shared libraries aren't built.
BUILD_DLTEST = @BUILD_DLTEST@
#BUILD_DLTEST =
TCL_LIB_FILE = @TCL_LIB_FILE@
#TCL_LIB_FILE = libtcl.a
# Generic lib name used in rules that apply to tcl and tk
LIB_FILE = ${TCL_LIB_FILE}
TCL_LIB_FLAG = @TCL_LIB_FLAG@
#TCL_LIB_FLAG = -ltcl
TCL_EXP_FILE = @TCL_EXP_FILE@
TCL_BUILD_EXP_FILE = @TCL_BUILD_EXP_FILE@
|
| ︙ | ︙ | |||
227 228 229 230 231 232 233 | SRC_DIR = @srcdir@ TOP_DIR = @srcdir@/.. GENERIC_DIR = $(TOP_DIR)/generic COMPAT_DIR = $(TOP_DIR)/compat TOOL_DIR = $(TOP_DIR)/tools UNIX_DIR = $(TOP_DIR)/unix MAC_OSX_DIR = $(TOP_DIR)/macosx | < > > > > > > > > > > > > > | 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 | SRC_DIR = @srcdir@ TOP_DIR = @srcdir@/.. GENERIC_DIR = $(TOP_DIR)/generic COMPAT_DIR = $(TOP_DIR)/compat TOOL_DIR = $(TOP_DIR)/tools UNIX_DIR = $(TOP_DIR)/unix 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 mkLinks to control whether the manpages # should be compressed and linked with softlinks MKLINKS_FLAGS = @MKLINKS_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. #---------------------------------------------------------------- GDB = gdb DDD = ddd #---------------------------------------------------------------- # The information below should be usable as is. The configure # script won't modify it and you shouldn't need to modify it # either. #---------------------------------------------------------------- |
| ︙ | ︙ | |||
400 401 402 403 404 405 406 | $(UNIX_DIR)/tclLoadDl2.c \ $(UNIX_DIR)/tclLoadDld.c \ $(UNIX_DIR)/tclLoadDyld.c \ $(GENERIC_DIR)/tclLoadNone.c \ $(UNIX_DIR)/tclLoadOSF.c \ $(UNIX_DIR)/tclLoadShl.c | | | | | | < < < | < | > > > > > | | 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 |
$(UNIX_DIR)/tclLoadDl2.c \
$(UNIX_DIR)/tclLoadDld.c \
$(UNIX_DIR)/tclLoadDyld.c \
$(GENERIC_DIR)/tclLoadNone.c \
$(UNIX_DIR)/tclLoadOSF.c \
$(UNIX_DIR)/tclLoadShl.c
MACOSX_SRCS = \
$(MAC_OSX_DIR)/tclMacOSXBundle.c
# Note: don't include DL_SRCS or MACOSX_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) $(STUB_SRCS)
all: binaries libraries doc
binaries: ${LIB_FILE} $(STUB_LIB_FILE) $(TCL_BUILD_EXP_FILE) tclsh
libraries:
doc:
# The following target is configured by autoconf to generate either
# a shared library or non-shared library for Tcl.
${LIB_FILE}: ${OBJS} ${STUB_LIB_FILE}
rm -f $@
@MAKE_LIB@
${STUB_LIB_FILE}: ${STUB_LIB_OBJS}
rm -f $@
@MAKE_STUB_LIB@
# Make target which outputs the list of the .o contained in the Tcl lib
# usefull to build a single big shared library containing Tcl and other
# extensions. used for the Tcl Plugin. -- dl
# The dependency on OBJS is not there because we just want the list
# of objects here, not actually building them
tclLibObjs:
@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} ${LDFLAGS} ${TCLSH_OBJS} @TCL_BUILD_LIB_SPEC@ ${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.
# 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} ${LDFLAGS} ${TCLTEST_OBJS} @TCL_BUILD_LIB_SPEC@ ${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"
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 |
runtest: tcltest
@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
TCL_LIBRARY="${TCL_BUILDTIME_LIBRARY}"; export TCL_LIBRARY; \
./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@; \
LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
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
| > > > > > > > > > > > > > > > > | > > > | | 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 |
runtest: tcltest
@LD_LIBRARY_PATH_VAR@=`pwd`:${@LD_LIBRARY_PATH_VAR@}; export @LD_LIBRARY_PATH_VAR@; \
LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
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=`pwd`:${LD_LIBRARY_PATH}; export LD_LIBRARY_PATH; \
DYLD_LIBRARY_PATH=`pwd`:${DYLD_LIBRARY_PATH}; export DYLD_LIBRARY_PATH; \
LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
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@; \
LIBPATH=`pwd`:${LIBPATH}; export LIBPATH; \
SHLIB_PATH=`pwd`:${SHLIB_PATH}; export SHLIB_PATH; \
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 LIBPATH=`pwd`:${LIBPATH}" >> gdb.run
@echo "set env SHLIB_PATH=`pwd`:${SHLIB_PATH}" >> 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 LIBPATH=`pwd`:${LIBPATH}" >> gdb.run
@echo "set env SHLIB_PATH=`pwd`:${SHLIB_PATH}" >> gdb.run
@echo "set env TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" >> gdb.run
$(DDD) -command=gdb.run ./tclsh
rm gdb.run
# 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).
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 | -e 's?SCCSID?RCS: @(#) ?' \ -e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \ -e '/TclDatenewstate:/d' -e '/#pragma/d' \ -e '/#include <inttypes.h>/d' -e 's/const /CONST /g' \ <y.tab.c >$(GENERIC_DIR)/tclDate.c rm y.tab.c | | | > | | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 |
-e 's?SCCSID?RCS: @(#) ?' \
-e '/#ifdef __STDC__/,/#endif/d' -e '/TclDateerrlab:/d' \
-e '/TclDatenewstate:/d' -e '/#pragma/d' \
-e '/#include <inttypes.h>/d' -e 's/const /CONST /g' \
<y.tab.c >$(GENERIC_DIR)/tclDate.c
rm y.tab.c
# The following target generates the shared libraries in dltest/ that
# are used for testing; they are included as part of the "tcltest"
# 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: install-binaries install-libraries install-doc
install-strip:
$(MAKE) install \
INSTALL_PROGRAM="$(INSTALL_PROGRAM) ${INSTALL_STRIP_PROGRAM}" \
|
| ︙ | ︙ | |||
557 558 559 560 561 562 563 | chmod 755 $$i; \ else true; \ fi; \ done; @if test ! -x $(SRC_DIR)/install-sh; then \ chmod +x $(SRC_DIR)/install-sh; \ fi | | | < < < | | | | < | | | 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 | chmod 755 $$i; \ else true; \ fi; \ done; @if test ! -x $(SRC_DIR)/install-sh; then \ chmod +x $(SRC_DIR)/install-sh; \ fi @echo "Installing $(LIB_FILE) to $(LIB_INSTALL_DIR)/" @@INSTALL_LIB@ @chmod 555 $(LIB_INSTALL_DIR)/$(LIB_FILE) @if test "$(TCL_BUILD_EXP_FILE)" != ""; then \ echo "Installing $(TCL_EXP_FILE) to $(LIB_INSTALL_DIR)/"; \ $(INSTALL_DATA) $(TCL_BUILD_EXP_FILE) \ $(LIB_INSTALL_DIR)/$(TCL_EXP_FILE); \ fi @echo "Installing tclsh as $(BIN_INSTALL_DIR)/tclsh$(VERSION)" @$(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; @for i in http2.4 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; \ |
| ︙ | ︙ | |||
626 627 628 629 630 631 632 | $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http2.4; \ 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; | | | | | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 | $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/http2.4; \ 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"; @for j in $(TOP_DIR)/library/msgcat/*.tcl ; \ do \ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/msgcat1.3; \ done; @echo "Installing library tcltest2.2 directory"; @for j in $(TOP_DIR)/library/tcltest/*.tcl ; \ do \ $(INSTALL_DATA) $$j $(SCRIPT_INSTALL_DIR)/tcltest2.2; \ 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 |
| ︙ | ︙ | |||
663 664 665 666 667 668 669 | do \ rm -f $(MAN1_INSTALL_DIR)/$$i; \ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ $$i > $(MAN1_INSTALL_DIR)/$$i; \ chmod 444 $(MAN1_INSTALL_DIR)/$$i; \ done; @echo "Cross-linking top-level (.1) docs"; | | | | | 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 | do \ rm -f $(MAN1_INSTALL_DIR)/$$i; \ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ $$i > $(MAN1_INSTALL_DIR)/$$i; \ chmod 444 $(MAN1_INSTALL_DIR)/$$i; \ done; @echo "Cross-linking top-level (.1) docs"; @$(UNIX_DIR)/mkLinks $(MKLINKS_FLAGS) $(MAN1_INSTALL_DIR) @echo "Installing C API (.3) docs"; @cd $(TOP_DIR)/doc; for i in *.3; \ do \ rm -f $(MAN3_INSTALL_DIR)/$$i; \ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ $$i > $(MAN3_INSTALL_DIR)/$$i; \ chmod 444 $(MAN3_INSTALL_DIR)/$$i; \ done; @echo "Cross-linking C API (.3) docs"; @$(UNIX_DIR)/mkLinks $(MKLINKS_FLAGS) $(MAN3_INSTALL_DIR) @echo "Installing command (.n) docs"; @cd $(TOP_DIR)/doc; for i in *.n; \ do \ rm -f $(MANN_INSTALL_DIR)/$$i; \ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \ $$i > $(MANN_INSTALL_DIR)/$$i; \ chmod 444 $(MANN_INSTALL_DIR)/$$i; \ done; @echo "Cross-linking command (.n) docs"; @$(UNIX_DIR)/mkLinks $(MKLINKS_FLAGS) $(MANN_INSTALL_DIR) 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 |
| ︙ | ︙ | |||
1018 1019 1020 1021 1022 1023 1024 |
# 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} \
@DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \
| | | 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 |
# 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} \
@DL_OBJS@ @TCL_BUILD_LIB_SPEC@ ${LIBS} \
${CC_SEARCH_FLAGS} -L/usr/openwin/lib -lXt -o xttest
tclXtNotify.o: $(UNIX_DIR)/tclXtNotify.c
$(CC) -c $(CC_SWITCHES) -I/usr/openwin/include \
$(UNIX_DIR)/tclXtNotify.c
tclXtTest.o: $(UNIX_DIR)/tclXtTest.c
$(CC) -c $(CC_SWITCHES) -I/usr/openwin/include \
|
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 | # # Target to regenerate header files and stub files from the *.decls tables. # $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls | > | > | 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 | # # Target to regenerate header files and stub files from the *.decls tables. # $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls @echo "Warning: tclStubInit.c may be out of date." @echo "Developers may want to run \"make genstubs\" to regenerate." @echo "This warning can be safely ignored, do not report as a bug!" genstubs: $(TCL_EXE) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \ $(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls # # Target to check that all exported functions have an entry in the stubs |
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 | # # 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. # DISTROOT = /tmp/dist | | | | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 |
#
# 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.
#
DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}.zip
DISTDIR = $(DISTROOT)/$(DISTNAME)
$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.in
autoconf $(UNIX_DIR)/configure.in > $(UNIX_DIR)/configure
dist: $(UNIX_DIR)/configure mklinks
rm -rf $(DISTDIR)
mkdir -p $(DISTDIR)/unix
|
| ︙ | ︙ | |||
1219 1220 1221 1222 1223 1224 1225 | $(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/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 | < < < | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 | $(TOP_DIR)/compat/*.h $(TOP_DIR)/compat/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 cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win cp $(TOP_DIR)/win/configure.in $(TOP_DIR)/win/configure \ $(TOP_DIR)/win/tclConfig.sh.in \ $(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \ $(DISTDIR)/win cp -p $(TOP_DIR)/win/*.c $(TOP_DIR)/win/*.h \ |
| ︙ | ︙ |
Changes to unix/README.
1 2 3 | Tcl UNIX README --------------- | | | 1 2 3 4 5 6 7 8 9 10 11 | Tcl UNIX README --------------- RCS: @(#) $Id: README,v 1.17.8.3 2002/08/20 20:25:29 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. |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
--enable-64bit-vis enable 64bit Sparc VIS support
--disable-64bit-vis disable 64bit Sparc VIS support
--enable-langinfo Allows use of modern nl_langinfo check for
better localization support. This is on by
default on platforms where nl_langinfo is
found.
--disable-langinfo Specifically disables use of nl_langinfo.
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.
Note: be sure to use only absolute path names (those starting with "/")
| > > > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
--enable-64bit-vis enable 64bit Sparc VIS support
--disable-64bit-vis disable 64bit Sparc VIS support
--enable-langinfo Allows use of modern nl_langinfo check for
better localization support. This is on by
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.
Note: be sure to use only absolute path names (those starting with "/")
|
| ︙ | ︙ |
Changes to unix/configure.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | # gives unlimited permission to copy, distribute and modify it. # Defaults: ac_help= ac_default_prefix=/usr/local # Any additions from configure.in: ac_help="$ac_help --enable-threads build with threads" ac_help="$ac_help --enable-langinfo use nl_langinfo if possible to determine encoding at startup, otherwise use old heuristic" ac_help="$ac_help --enable-64bit enable 64bit support (where applicable)" ac_help="$ac_help --enable-64bit-vis enable 64bit Sparc VIS support" ac_help="$ac_help --disable-load disallow dynamic loading and "load" command" ac_help="$ac_help --enable-symbols build with debugging symbols [--disable-symbols]" ac_help="$ac_help | > > > > > > > < < | | 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 |
# gives unlimited permission to copy, distribute and modify it.
# Defaults:
ac_help=
ac_default_prefix=/usr/local
# Any additions from configure.in:
ac_help="$ac_help
--enable-man-symlinks use symlinks for the manpages"
ac_help="$ac_help
--enable-man-compression=PROG
compress the manpages with PROG"
ac_help="$ac_help
--enable-threads build with threads"
ac_help="$ac_help
--enable-langinfo use nl_langinfo if possible to determine
encoding at startup, otherwise use old heuristic"
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)"
ac_help="$ac_help
--enable-64bit-vis enable 64bit Sparc VIS support"
ac_help="$ac_help
--disable-load disallow dynamic loading and "load" command"
ac_help="$ac_help
--enable-symbols build with debugging symbols [--disable-symbols]"
ac_help="$ac_help
--enable-framework package shared libraries in frameworks [--disable-framework]"
# Initialize some variables set by options.
# The variables have the same names as the options, with
# dashes changed to underlines.
build=NONE
cache_file=./config.cache
exec_prefix=NONE
|
| ︙ | ︙ | |||
534 535 536 537 538 539 540 541 542 543 544 |
ac_n=-n ac_c= ac_t=
fi
else
ac_n= ac_c='\c' ac_t=
fi
TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
| > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
ac_n=-n ac_c= ac_t=
fi
else
ac_n= ac_c='\c' ac_t=
fi
TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="b3"
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
# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`
#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------
echo $ac_n "checking whether to use symlinks for manpages""... $ac_c" 1>&6
echo "configure:575: checking whether to use symlinks for manpages" >&5
# Check whether --enable-man-symlinks or --disable-man-symlinks was given.
if test "${enable_man_symlinks+set}" = set; then
enableval="$enable_man_symlinks"
test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --symlinks"
else
enableval="no"
fi
echo "$ac_t""$enableval" 1>&6
echo $ac_n "checking compression for manpages""... $ac_c" 1>&6
echo "configure:587: checking compression for manpages" >&5
# Check whether --enable-man-compression or --disable-man-compression was given.
if test "${enable_man_compression+set}" = set; then
enableval="$enable_man_compression"
test "$enableval" = "yes" && echo && { echo "configure: error: missing argument to --enable-man-compression" 1>&2; exit 1; }
test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --compress $enableval"
else
enableval="no"
fi
echo "$ac_t""$enableval" 1>&6
#------------------------------------------------------------------------
# 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
# 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:615: 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=":"
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 | 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 | | | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 |
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:645: 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=":"
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
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
| | | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 |
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:696: 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=":"
|
| ︙ | ︙ | |||
681 682 683 684 685 686 687 |
;;
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
| | | | | 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 |
;;
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:728: 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 739 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
if { (eval echo configure:744: \"$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
|
| ︙ | ︙ | |||
723 724 725 726 727 728 729 |
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
| | | | | | 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 |
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:770: 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:775: 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:784: \"$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:803: 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
|
| ︙ | ︙ | |||
787 788 789 790 791 792 793 |
if test "$GCC" = yes; then
CFLAGS="-O2"
else
CFLAGS=
fi
fi
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | | 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 |
if test "$GCC" = yes; then
CFLAGS="-O2"
else
CFLAGS=
fi
fi
echo $ac_n "checking how to run the C preprocessor""... $ac_c" 1>&6
echo "configure:835: 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 850 "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:856: \"$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 867 "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:873: \"$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 884 "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:890: \"$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
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 | fi echo "$ac_t""$CPP" 1>&6 for ac_hdr in unistd.h limits.h do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 | | | | | 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 |
fi
echo "$ac_t""$CPP" 1>&6
for ac_hdr in unistd.h limits.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:918: checking for $ac_hdr" >&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 923 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:928: \"$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
|
| ︙ | ︙ | |||
944 945 946 947 948 949 950 |
#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------
echo $ac_n "checking for building with threads""... $ac_c" 1>&6
| | | 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------
echo $ac_n "checking for building with threads""... $ac_c" 1>&6
echo "configure:961: 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
|
| ︙ | ︙ | |||
976 977 978 979 980 981 982 | EOF cat >> confdefs.h <<\EOF #define _THREAD_SAFE 1 EOF echo $ac_n "checking for pthread_mutex_init in -lpthread""... $ac_c" 1>&6 | | | | | 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 |
EOF
cat >> confdefs.h <<\EOF
#define _THREAD_SAFE 1
EOF
echo $ac_n "checking for pthread_mutex_init in -lpthread""... $ac_c" 1>&6
echo "configure:993: checking for pthread_mutex_init in -lpthread" >&5
ac_lib_var=`echo pthread'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lpthread $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1001 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char pthread_mutex_init();
int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1012: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 | 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] echo $ac_n "checking for __pthread_mutex_init in -lpthread""... $ac_c" 1>&6 | | | | | 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 |
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]
echo $ac_n "checking for __pthread_mutex_init in -lpthread""... $ac_c" 1>&6
echo "configure:1040: checking for __pthread_mutex_init in -lpthread" >&5
ac_lib_var=`echo pthread'_'__pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lpthread $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1048 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char __pthread_mutex_init();
int main() {
__pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1059: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
1070 1071 1072 1073 1074 1075 1076 | fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthread" else echo $ac_n "checking for pthread_mutex_init in -lpthreads""... $ac_c" 1>&6 | | | | | 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 |
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthread"
else
echo $ac_n "checking for pthread_mutex_init in -lpthreads""... $ac_c" 1>&6
echo "configure:1087: checking for pthread_mutex_init in -lpthreads" >&5
ac_lib_var=`echo pthreads'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lpthreads $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1095 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char pthread_mutex_init();
int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1106: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 | fi if test "$tcl_ok" = "yes"; then # The space is needed THREADS_LIBS=" -lpthreads" else echo $ac_n "checking for pthread_mutex_init in -lc""... $ac_c" 1>&6 | | | | | 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 |
fi
if test "$tcl_ok" = "yes"; then
# The space is needed
THREADS_LIBS=" -lpthreads"
else
echo $ac_n "checking for pthread_mutex_init in -lc""... $ac_c" 1>&6
echo "configure:1132: checking for pthread_mutex_init in -lc" >&5
ac_lib_var=`echo c'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lc $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1140 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char pthread_mutex_init();
int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1151: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 | else echo "$ac_t""no" 1>&6 tcl_ok=no fi if test "$tcl_ok" = "no"; then echo $ac_n "checking for pthread_mutex_init in -lc_r""... $ac_c" 1>&6 | | | | | 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 |
else
echo "$ac_t""no" 1>&6
tcl_ok=no
fi
if test "$tcl_ok" = "no"; then
echo $ac_n "checking for pthread_mutex_init in -lc_r""... $ac_c" 1>&6
echo "configure:1174: checking for pthread_mutex_init in -lc_r" >&5
ac_lib_var=`echo c_r'_'pthread_mutex_init | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lc_r $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1182 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char pthread_mutex_init();
int main() {
pthread_mutex_init()
; return 0; }
EOF
if { (eval echo configure:1193: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 | # Does the pthread-implementation provide # 'pthread_attr_setstacksize' ? for ac_func in pthread_attr_setstacksize do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 | | | | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 |
# Does the pthread-implementation provide
# 'pthread_attr_setstacksize' ?
for ac_func in pthread_attr_setstacksize
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1231: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1236 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
1242 1243 1244 1245 1246 1247 1248 | choke me #else $ac_func(); #endif ; return 0; } EOF | | | 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 |
choke me
#else
$ac_func();
#endif
; return 0; }
EOF
if { (eval echo configure:1259: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_$ac_func=no"
|
| ︙ | ︙ | |||
1269 1270 1271 1272 1273 1274 1275 | echo "$ac_t""no" 1>&6 fi done for ac_func in readdir_r do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 | | | | 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 |
echo "$ac_t""no" 1>&6
fi
done
for ac_func in readdir_r
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1286: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1291 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
1297 1298 1299 1300 1301 1302 1303 | choke me #else $ac_func(); #endif ; return 0; } EOF | | | 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 |
choke me
#else
$ac_func();
#endif
; return 0; }
EOF
if { (eval echo configure:1314: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_$ac_func=no"
|
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 | # 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"; then if test -n "$GCC"; then echo $ac_n "checking if the compiler understands -pipe""... $ac_c" 1>&6 | | | | | | | | | | 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 |
# 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"; then
if test -n "$GCC"; then
echo $ac_n "checking if the compiler understands -pipe""... $ac_c" 1>&6
echo "configure:1353: checking if the compiler understands -pipe" >&5
OLDCC="$CC"
CC="$CC -pipe"
cat > conftest.$ac_ext <<EOF
#line 1357 "configure"
#include "confdefs.h"
int main() {
; return 0; }
EOF
if { (eval echo configure:1364: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
echo "$ac_t""yes" 1>&6
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
CC="$OLDCC"
echo "$ac_t""no" 1>&6
fi
rm -f conftest*
fi
fi
#--------------------------------------------------------------------
# Detect what compiler flags to set for 64-bit support.
#--------------------------------------------------------------------
echo $ac_n "checking for required early compiler flags""... $ac_c" 1>&6
echo "configure:1384: checking for required early compiler flags" >&5
tcl_flags=""
if eval "test \"`echo '$''{'tcl_cv_flag__isoc99_source'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1391 "configure"
#include "confdefs.h"
#include <stdlib.h>
int main() {
char *p = (char *)strtoll; char *q = (char *)strtoull;
; return 0; }
EOF
if { (eval echo configure:1398: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_flag__isoc99_source=no
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
cat > conftest.$ac_ext <<EOF
#line 1406 "configure"
#include "confdefs.h"
#define _ISOC99_SOURCE 1
#include <stdlib.h>
int main() {
char *p = (char *)strtoll; char *q = (char *)strtoull;
; return 0; }
EOF
if { (eval echo configure:1414: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_flag__isoc99_source=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_flag__isoc99_source=no
|
| ︙ | ︙ | |||
1423 1424 1425 1426 1427 1428 1429 |
tcl_flags="$tcl_flags _ISOC99_SOURCE"
fi
if eval "test \"`echo '$''{'tcl_cv_flag__largefile64_source'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
| | | | | | 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 |
tcl_flags="$tcl_flags _ISOC99_SOURCE"
fi
if eval "test \"`echo '$''{'tcl_cv_flag__largefile64_source'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1440 "configure"
#include "confdefs.h"
#include <sys/stat.h>
int main() {
struct stat64 buf; int i = stat64("/", &buf);
; return 0; }
EOF
if { (eval echo configure:1447: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_flag__largefile64_source=no
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
cat > conftest.$ac_ext <<EOF
#line 1455 "configure"
#include "confdefs.h"
#define _LARGEFILE64_SOURCE 1
#include <sys/stat.h>
int main() {
struct stat64 buf; int i = stat64("/", &buf);
; return 0; }
EOF
if { (eval echo configure:1463: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_flag__largefile64_source=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_flag__largefile64_source=no
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
echo "$ac_t""none" 1>&6
else
echo "$ac_t""${tcl_flags}" 1>&6
fi
echo $ac_n "checking for 64-bit integer type""... $ac_c" 1>&6
| | | | | | | 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 |
echo "$ac_t""none" 1>&6
else
echo "$ac_t""${tcl_flags}" 1>&6
fi
echo $ac_n "checking for 64-bit integer type""... $ac_c" 1>&6
echo "configure:1492: checking for 64-bit integer type" >&5
if eval "test \"`echo '$''{'tcl_cv_type_64bit'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1498 "configure"
#include "confdefs.h"
int main() {
__int64 value = (__int64) 0;
; return 0; }
EOF
if { (eval echo configure:1505: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_type_64bit=__int64
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_type_64bit=none
if test "$cross_compiling" = yes; then
{ echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
cat > conftest.$ac_ext <<EOF
#line 1517 "configure"
#include "confdefs.h"
#include <unistd.h>
int main() {exit(!(sizeof(long long) > sizeof(long)));}
EOF
if { (eval echo configure:1523: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_cv_type_64bit="long long"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
fi
rm -fr conftest*
|
| ︙ | ︙ | |||
1531 1532 1533 1534 1535 1536 1537 |
#define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit}
EOF
echo "$ac_t""${tcl_cv_type_64bit}" 1>&6
# Now check for auxiliary declarations
echo $ac_n "checking for struct dirent64""... $ac_c" 1>&6
| | | | | | | | | | | 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 |
#define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit}
EOF
echo "$ac_t""${tcl_cv_type_64bit}" 1>&6
# Now check for auxiliary declarations
echo $ac_n "checking for struct dirent64""... $ac_c" 1>&6
echo "configure:1548: checking for struct dirent64" >&5
if eval "test \"`echo '$''{'tcl_cv_struct_dirent64'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1554 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/dirent.h>
int main() {
struct dirent64 p;
; return 0; }
EOF
if { (eval echo configure:1562: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_struct_dirent64=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_struct_dirent64=no
fi
rm -f conftest*
fi
if test "x${tcl_cv_struct_dirent64}" = "xyes" ; then
cat >> confdefs.h <<\EOF
#define HAVE_STRUCT_DIRENT64 1
EOF
fi
echo "$ac_t""${tcl_cv_struct_dirent64}" 1>&6
echo $ac_n "checking for struct stat64""... $ac_c" 1>&6
echo "configure:1583: checking for struct stat64" >&5
if eval "test \"`echo '$''{'tcl_cv_struct_stat64'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1589 "configure"
#include "confdefs.h"
#include <sys/stat.h>
int main() {
struct stat64 p;
; return 0; }
EOF
if { (eval echo configure:1597: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_struct_stat64=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_struct_stat64=no
fi
rm -f conftest*
fi
if test "x${tcl_cv_struct_stat64}" = "xyes" ; then
cat >> confdefs.h <<\EOF
#define HAVE_STRUCT_STAT64 1
EOF
fi
echo "$ac_t""${tcl_cv_struct_stat64}" 1>&6
echo $ac_n "checking for off64_t""... $ac_c" 1>&6
echo "configure:1618: checking for off64_t" >&5
if eval "test \"`echo '$''{'tcl_cv_type_off64_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1624 "configure"
#include "confdefs.h"
#include <sys/types.h>
int main() {
off64_t offset;
; return 0; }
EOF
if { (eval echo configure:1632: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_type_off64_t=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_type_off64_t=no
|
| ︙ | ︙ | |||
1642 1643 1644 1645 1646 1647 1648 | #-------------------------------------------------------------------- # Check endianness because we can optimize comparisons of # Tcl_UniChar strings to memcmp on big-endian systems. #-------------------------------------------------------------------- echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6 | | | | | | | | | 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 |
#--------------------------------------------------------------------
# Check endianness because we can optimize comparisons of
# Tcl_UniChar strings to memcmp on big-endian systems.
#--------------------------------------------------------------------
echo $ac_n "checking whether byte ordering is bigendian""... $ac_c" 1>&6
echo "configure:1659: checking whether byte ordering is bigendian" >&5
if eval "test \"`echo '$''{'ac_cv_c_bigendian'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_cv_c_bigendian=unknown
# See if sys/param.h defines the BYTE_ORDER macro.
cat > conftest.$ac_ext <<EOF
#line 1666 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/param.h>
int main() {
#if !BYTE_ORDER || !BIG_ENDIAN || !LITTLE_ENDIAN
bogus endian macros
#endif
; return 0; }
EOF
if { (eval echo configure:1677: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
# It does; now see whether it defined to BIG_ENDIAN or not.
cat > conftest.$ac_ext <<EOF
#line 1681 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/param.h>
int main() {
#if BYTE_ORDER != BIG_ENDIAN
not big endian
#endif
; return 0; }
EOF
if { (eval echo configure:1692: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_c_bigendian=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_c_bigendian=no
fi
rm -f conftest*
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
fi
rm -f conftest*
if test $ac_cv_c_bigendian = unknown; then
if test "$cross_compiling" = yes; then
{ echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
cat > conftest.$ac_ext <<EOF
#line 1712 "configure"
#include "confdefs.h"
main () {
/* Are we little or big endian? From Harbison&Steele. */
union
{
long l;
char c[sizeof (long)];
} u;
u.l = 1;
exit (u.c[sizeof (long) - 1] == 1);
}
EOF
if { (eval echo configure:1725: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
ac_cv_c_bigendian=no
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
ac_cv_c_bigendian=yes
|
| ︙ | ︙ | |||
1741 1742 1743 1744 1745 1746 1747 | # set flags so Tcl uses alternate procedures. #-------------------------------------------------------------------- # Check if Posix compliant getcwd exists, if not we'll use getwd. for ac_func in getcwd do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 | | | | 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 |
# set flags so Tcl uses alternate procedures.
#--------------------------------------------------------------------
# Check if Posix compliant getcwd exists, if not we'll use getwd.
for ac_func in getcwd
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1758: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1763 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
1769 1770 1771 1772 1773 1774 1775 | choke me #else $ac_func(); #endif ; return 0; } EOF | | | 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 |
choke me
#else
$ac_func();
#endif
; return 0; }
EOF
if { (eval echo configure:1786: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_$ac_func=no"
|
| ︙ | ︙ | |||
1803 1804 1805 1806 1807 1808 1809 | # 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 ? for ac_func in opendir strstr do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 | | | | 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 |
# 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 ?
for ac_func in opendir strstr
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1820: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1825 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
1831 1832 1833 1834 1835 1836 1837 | choke me #else $ac_func(); #endif ; return 0; } EOF | | | 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 |
choke me
#else
$ac_func();
#endif
; return 0; }
EOF
if { (eval echo configure:1848: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_$ac_func=no"
|
| ︙ | ︙ | |||
1861 1862 1863 1864 1865 1866 1867 | done for ac_func in strtol strtoll strtoull tmpnam waitpid do echo $ac_n "checking for $ac_func""... $ac_c" 1>&6 | | | | 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 |
done
for ac_func in strtol strtoll strtoull tmpnam waitpid
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:1878: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1883 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
1889 1890 1891 1892 1893 1894 1895 | choke me #else $ac_func(); #endif ; return 0; } EOF | | | 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 |
choke me
#else
$ac_func();
#endif
; return 0; }
EOF
if { (eval echo configure:1906: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_$ac_func=no"
|
| ︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 |
echo "$ac_t""no" 1>&6
LIBOBJS="$LIBOBJS ${ac_func}.${ac_objext}"
fi
done
echo $ac_n "checking for strerror""... $ac_c" 1>&6
| | | | 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 |
echo "$ac_t""no" 1>&6
LIBOBJS="$LIBOBJS ${ac_func}.${ac_objext}"
fi
done
echo $ac_n "checking for strerror""... $ac_c" 1>&6
echo "configure:1933: checking for strerror" >&5
if eval "test \"`echo '$''{'ac_cv_func_strerror'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1938 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strerror(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
1944 1945 1946 1947 1948 1949 1950 | choke me #else strerror(); #endif ; return 0; } EOF | | | 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 |
choke me
#else
strerror();
#endif
; return 0; }
EOF
if { (eval echo configure:1961: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strerror=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_strerror=no"
|
| ︙ | ︙ | |||
1968 1969 1970 1971 1972 1973 1974 | cat >> confdefs.h <<\EOF #define NO_STRERROR 1 EOF fi echo $ac_n "checking for getwd""... $ac_c" 1>&6 | | | | 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 |
cat >> confdefs.h <<\EOF
#define NO_STRERROR 1
EOF
fi
echo $ac_n "checking for getwd""... $ac_c" 1>&6
echo "configure:1985: checking for getwd" >&5
if eval "test \"`echo '$''{'ac_cv_func_getwd'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1990 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char getwd(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
1996 1997 1998 1999 2000 2001 2002 | choke me #else getwd(); #endif ; return 0; } EOF | | | 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 |
choke me
#else
getwd();
#endif
; return 0; }
EOF
if { (eval echo configure:2013: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_getwd=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_getwd=no"
|
| ︙ | ︙ | |||
2020 2021 2022 2023 2024 2025 2026 | cat >> confdefs.h <<\EOF #define NO_GETWD 1 EOF fi echo $ac_n "checking for wait3""... $ac_c" 1>&6 | | | | 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 |
cat >> confdefs.h <<\EOF
#define NO_GETWD 1
EOF
fi
echo $ac_n "checking for wait3""... $ac_c" 1>&6
echo "configure:2037: checking for wait3" >&5
if eval "test \"`echo '$''{'ac_cv_func_wait3'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 2042 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char wait3(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
2048 2049 2050 2051 2052 2053 2054 | choke me #else wait3(); #endif ; return 0; } EOF | | | 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 |
choke me
#else
wait3();
#endif
; return 0; }
EOF
if { (eval echo configure:2065: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_wait3=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_wait3=no"
|
| ︙ | ︙ | |||
2072 2073 2074 2075 2076 2077 2078 | cat >> confdefs.h <<\EOF #define NO_WAIT3 1 EOF fi echo $ac_n "checking for uname""... $ac_c" 1>&6 | | | | 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 |
cat >> confdefs.h <<\EOF
#define NO_WAIT3 1
EOF
fi
echo $ac_n "checking for uname""... $ac_c" 1>&6
echo "configure:2089: checking for uname" >&5
if eval "test \"`echo '$''{'ac_cv_func_uname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 2094 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char uname(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
2100 2101 2102 2103 2104 2105 2106 | choke me #else uname(); #endif ; return 0; } EOF | | | 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 |
choke me
#else
uname();
#endif
; return 0; }
EOF
if { (eval echo configure:2117: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_uname=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_uname=no"
|
| ︙ | ︙ | |||
2124 2125 2126 2127 2128 2129 2130 | cat >> confdefs.h <<\EOF #define NO_UNAME 1 EOF fi echo $ac_n "checking for realpath""... $ac_c" 1>&6 | | | | 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 |
cat >> confdefs.h <<\EOF
#define NO_UNAME 1
EOF
fi
echo $ac_n "checking for realpath""... $ac_c" 1>&6
echo "configure:2141: checking for realpath" >&5
if eval "test \"`echo '$''{'ac_cv_func_realpath'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 2146 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char realpath(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
2152 2153 2154 2155 2156 2157 2158 | choke me #else realpath(); #endif ; return 0; } EOF | | | 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 |
choke me
#else
realpath();
#endif
; return 0; }
EOF
if { (eval echo configure:2169: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_realpath=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_realpath=no"
|
| ︙ | ︙ | |||
2187 2188 2189 2190 2191 2192 2193 |
# strtod insome versions of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
#--------------------------------------------------------------------
echo $ac_n "checking dirent.h""... $ac_c" 1>&6
| | | | 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 |
# strtod insome versions of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
#--------------------------------------------------------------------
echo $ac_n "checking dirent.h""... $ac_c" 1>&6
echo "configure:2204: checking dirent.h" >&5
cat > conftest.$ac_ext <<EOF
#line 2206 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <dirent.h>
int main() {
#ifndef _POSIX_SOURCE
# ifdef __Lynx__
|
| ︙ | ︙ | |||
2215 2216 2217 2218 2219 2220 2221 |
d = opendir("foobar");
entryPtr = readdir(d);
p = entryPtr->d_name;
closedir(d);
; return 0; }
EOF
| | | | | | 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 |
d = opendir("foobar");
entryPtr = readdir(d);
p = entryPtr->d_name;
closedir(d);
; return 0; }
EOF
if { (eval echo configure:2232: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
tcl_ok=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_ok=no
fi
rm -f conftest*
if test $tcl_ok = no; then
cat >> confdefs.h <<\EOF
#define NO_DIRENT_H 1
EOF
fi
echo "$ac_t""$tcl_ok" 1>&6
ac_safe=`echo "errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for errno.h""... $ac_c" 1>&6
echo "configure:2253: 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 2258 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2263: \"$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
|
| ︙ | ︙ | |||
2273 2274 2275 2276 2277 2278 2279 |
#define NO_ERRNO_H 1
EOF
fi
ac_safe=`echo "float.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for float.h""... $ac_c" 1>&6
| | | | | 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 |
#define NO_ERRNO_H 1
EOF
fi
ac_safe=`echo "float.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for float.h""... $ac_c" 1>&6
echo "configure:2290: checking for float.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 2295 "configure"
#include "confdefs.h"
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2300: \"$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
|
| ︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 |
#define NO_FLOAT_H 1
EOF
fi
ac_safe=`echo "values.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for values.h""... $ac_c" 1>&6
| | | | | 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 |
#define NO_FLOAT_H 1
EOF
fi
ac_safe=`echo "values.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for values.h""... $ac_c" 1>&6
echo "configure:2327: checking for values.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 2332 "configure"
#include "confdefs.h"
#include <values.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2337: \"$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
|
| ︙ | ︙ | |||
2347 2348 2349 2350 2351 2352 2353 |
#define NO_VALUES_H 1
EOF
fi
ac_safe=`echo "limits.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for limits.h""... $ac_c" 1>&6
| | | | | 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 |
#define NO_VALUES_H 1
EOF
fi
ac_safe=`echo "limits.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for limits.h""... $ac_c" 1>&6
echo "configure:2364: checking for limits.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 2369 "configure"
#include "confdefs.h"
#include <limits.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2374: \"$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
|
| ︙ | ︙ | |||
2384 2385 2386 2387 2388 2389 2390 |
#define NO_LIMITS_H 1
EOF
fi
ac_safe=`echo "stdlib.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for stdlib.h""... $ac_c" 1>&6
| | | | | 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 |
#define NO_LIMITS_H 1
EOF
fi
ac_safe=`echo "stdlib.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for stdlib.h""... $ac_c" 1>&6
echo "configure:2401: checking for stdlib.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 2406 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2411: \"$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
|
| ︙ | ︙ | |||
2417 2418 2419 2420 2421 2422 2423 |
tcl_ok=1
else
echo "$ac_t""no" 1>&6
tcl_ok=0
fi
cat > conftest.$ac_ext <<EOF
| | | | | | | | 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 |
tcl_ok=1
else
echo "$ac_t""no" 1>&6
tcl_ok=0
fi
cat > conftest.$ac_ext <<EOF
#line 2434 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "strtol" >/dev/null 2>&1; then
:
else
rm -rf conftest*
tcl_ok=0
fi
rm -f conftest*
cat > conftest.$ac_ext <<EOF
#line 2448 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "strtoul" >/dev/null 2>&1; then
:
else
rm -rf conftest*
tcl_ok=0
fi
rm -f conftest*
cat > conftest.$ac_ext <<EOF
#line 2462 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "strtod" >/dev/null 2>&1; then
:
else
rm -rf conftest*
tcl_ok=0
fi
rm -f conftest*
if test $tcl_ok = 0; then
cat >> confdefs.h <<\EOF
#define NO_STDLIB_H 1
EOF
fi
ac_safe=`echo "string.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for string.h""... $ac_c" 1>&6
echo "configure:2483: checking for string.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 2488 "configure"
#include "confdefs.h"
#include <string.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2493: \"$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
|
| ︙ | ︙ | |||
2499 2500 2501 2502 2503 2504 2505 |
tcl_ok=1
else
echo "$ac_t""no" 1>&6
tcl_ok=0
fi
cat > conftest.$ac_ext <<EOF
| | | | 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 |
tcl_ok=1
else
echo "$ac_t""no" 1>&6
tcl_ok=0
fi
cat > conftest.$ac_ext <<EOF
#line 2516 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "strstr" >/dev/null 2>&1; then
:
else
rm -rf conftest*
tcl_ok=0
fi
rm -f conftest*
cat > conftest.$ac_ext <<EOF
#line 2530 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "strerror" >/dev/null 2>&1; then
:
else
|
| ︙ | ︙ | |||
2539 2540 2541 2542 2543 2544 2545 |
#define NO_STRING_H 1
EOF
fi
ac_safe=`echo "sys/wait.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for sys/wait.h""... $ac_c" 1>&6
| | | | | 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 |
#define NO_STRING_H 1
EOF
fi
ac_safe=`echo "sys/wait.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for sys/wait.h""... $ac_c" 1>&6
echo "configure:2556: checking for sys/wait.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 2561 "configure"
#include "confdefs.h"
#include <sys/wait.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2566: \"$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
|
| ︙ | ︙ | |||
2576 2577 2578 2579 2580 2581 2582 |
#define NO_SYS_WAIT_H 1
EOF
fi
ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6
| | | | | 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 |
#define NO_SYS_WAIT_H 1
EOF
fi
ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6
echo "configure:2593: checking for dlfcn.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 2598 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2603: \"$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
|
| ︙ | ︙ | |||
2618 2619 2620 2621 2622 2623 2624 |
# OS/390 lacks sys/param.h (and doesn't need it, by chance).
for ac_hdr in unistd.h sys/param.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
| | | | | 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 |
# OS/390 lacks sys/param.h (and doesn't need it, by chance).
for ac_hdr in unistd.h sys/param.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:2635: checking for $ac_hdr" >&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 2640 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2645: \"$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
|
| ︙ | ︙ | |||
2668 2669 2670 2671 2672 2673 2674 |
#---------------------------------------------------------------------------
for ac_hdr in sys/modem.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
| | | | | 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 |
#---------------------------------------------------------------------------
for ac_hdr in sys/modem.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:2685: checking for $ac_hdr" >&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 2690 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:2695: \"$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
|
| ︙ | ︙ | |||
2705 2706 2707 2708 2709 2710 2711 |
else
echo "$ac_t""no" 1>&6
fi
done
echo $ac_n "checking termios vs. termio vs. sgtty""... $ac_c" 1>&6
| | | | | | | | | | | | | | | | | 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 |
else
echo "$ac_t""no" 1>&6
fi
done
echo $ac_n "checking termios vs. termio vs. sgtty""... $ac_c" 1>&6
echo "configure:2722: checking termios vs. termio vs. sgtty" >&5
if eval "test \"`echo '$''{'tcl_cv_api_serial'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test "$cross_compiling" = yes; then
tcl_cv_api_serial=no
else
cat > conftest.$ac_ext <<EOF
#line 2731 "configure"
#include "confdefs.h"
#include <termios.h>
int main() {
struct termios t;
if (tcgetattr(0, &t) == 0) {
cfsetospeed(&t, 0);
t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
return 0;
}
return 1;
}
EOF
if { (eval echo configure:2746: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_cv_api_serial=termios
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_cv_api_serial=no
fi
rm -fr conftest*
fi
if test $tcl_cv_api_serial = no ; then
if test "$cross_compiling" = yes; then
tcl_cv_api_serial=no
else
cat > conftest.$ac_ext <<EOF
#line 2763 "configure"
#include "confdefs.h"
#include <termio.h>
int main() {
struct termio t;
if (ioctl(0, TCGETA, &t) == 0) {
t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
return 0;
}
return 1;
}
EOF
if { (eval echo configure:2777: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_cv_api_serial=termio
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_cv_api_serial=no
fi
rm -fr conftest*
fi
fi
if test $tcl_cv_api_serial = no ; then
if test "$cross_compiling" = yes; then
tcl_cv_api_serial=no
else
cat > conftest.$ac_ext <<EOF
#line 2795 "configure"
#include "confdefs.h"
#include <sgtty.h>
int main() {
struct sgttyb t;
if (ioctl(0, TIOCGETP, &t) == 0) {
t.sg_ospeed = 0;
t.sg_flags |= ODDP | EVENP | RAW;
return 0;
}
return 1;
}
EOF
if { (eval echo configure:2810: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_cv_api_serial=sgtty
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_cv_api_serial=no
fi
rm -fr conftest*
fi
fi
if test $tcl_cv_api_serial = no ; then
if test "$cross_compiling" = yes; then
tcl_cv_api_serial=no
else
cat > conftest.$ac_ext <<EOF
#line 2828 "configure"
#include "confdefs.h"
#include <termios.h>
#include <errno.h>
int main() {
struct termios t;
if (tcgetattr(0, &t) == 0
|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
cfsetospeed(&t, 0);
t.c_cflag |= PARENB | PARODD | CSIZE | CSTOPB;
return 0;
}
return 1;
}
EOF
if { (eval echo configure:2845: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_cv_api_serial=termios
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_cv_api_serial=no
fi
rm -fr conftest*
fi
fi
if test $tcl_cv_api_serial = no; then
if test "$cross_compiling" = yes; then
tcl_cv_api_serial=no
else
cat > conftest.$ac_ext <<EOF
#line 2863 "configure"
#include "confdefs.h"
#include <termio.h>
#include <errno.h>
int main() {
struct termio t;
if (ioctl(0, TCGETA, &t) == 0
|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
t.c_cflag |= CBAUD | PARENB | PARODD | CSIZE | CSTOPB;
return 0;
}
return 1;
}
EOF
if { (eval echo configure:2879: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_cv_api_serial=termio
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_cv_api_serial=no
fi
rm -fr conftest*
fi
fi
if test $tcl_cv_api_serial = no; then
if test "$cross_compiling" = yes; then
tcl_cv_api_serial=none
else
cat > conftest.$ac_ext <<EOF
#line 2897 "configure"
#include "confdefs.h"
#include <sgtty.h>
#include <errno.h>
int main() {
struct sgttyb t;
if (ioctl(0, TIOCGETP, &t) == 0
|| errno == ENOTTY || errno == ENXIO || errno == EINVAL) {
t.sg_ospeed = 0;
t.sg_flags |= ODDP | EVENP | RAW;
return 0;
}
return 1;
}
EOF
if { (eval echo configure:2914: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_cv_api_serial=sgtty
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_cv_api_serial=none
|
| ︙ | ︙ | |||
2940 2941 2942 2943 2944 2945 2946 | # 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. #-------------------------------------------------------------------- echo $ac_n "checking for fd_set in sys/types""... $ac_c" 1>&6 | | | | | | | 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 |
# 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.
#--------------------------------------------------------------------
echo $ac_n "checking for fd_set in sys/types""... $ac_c" 1>&6
echo "configure:2957: checking for fd_set in sys/types" >&5
if eval "test \"`echo '$''{'tcl_cv_type_fd_set'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 2962 "configure"
#include "confdefs.h"
#include <sys/types.h>
int main() {
fd_set readMask, writeMask;
; return 0; }
EOF
if { (eval echo configure:2969: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_type_fd_set=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_type_fd_set=no
fi
rm -f conftest*
fi
echo "$ac_t""$tcl_cv_type_fd_set" 1>&6
tk_ok=$tcl_cv_type_fd_set
if test $tcl_cv_type_fd_set = no; then
echo $ac_n "checking for fd_mask in sys/select""... $ac_c" 1>&6
echo "configure:2985: checking for fd_mask in sys/select" >&5
if eval "test \"`echo '$''{'tcl_cv_grep_fd_mask'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 2990 "configure"
#include "confdefs.h"
#include <sys/select.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "fd_mask" >/dev/null 2>&1; then
rm -rf conftest*
tcl_cv_grep_fd_mask=present
|
| ︙ | ︙ | |||
3010 3011 3012 3013 3014 3015 3016 | fi #------------------------------------------------------------------------------ # Find out all about time handling differences. #------------------------------------------------------------------------------ echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6 | | | | | 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 |
fi
#------------------------------------------------------------------------------
# Find out all about time handling differences.
#------------------------------------------------------------------------------
echo $ac_n "checking whether struct tm is in sys/time.h or time.h""... $ac_c" 1>&6
echo "configure:3027: checking whether struct tm is in sys/time.h or time.h" >&5
if eval "test \"`echo '$''{'ac_cv_struct_tm'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3032 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <time.h>
int main() {
struct tm *tp; tp->tm_sec;
; return 0; }
EOF
if { (eval echo configure:3040: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_tm=time.h
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_struct_tm=sys/time.h
|
| ︙ | ︙ | |||
3048 3049 3050 3051 3052 3053 3054 |
fi
for ac_hdr in sys/time.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
| | | | | 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 |
fi
for ac_hdr in sys/time.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:3065: checking for $ac_hdr" >&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 3070 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:3075: \"$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
|
| ︙ | ︙ | |||
3085 3086 3087 3088 3089 3090 3091 |
else
echo "$ac_t""no" 1>&6
fi
done
echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6
| | | | | | | | | | | 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 |
else
echo "$ac_t""no" 1>&6
fi
done
echo $ac_n "checking whether time.h and sys/time.h may both be included""... $ac_c" 1>&6
echo "configure:3102: checking whether time.h and sys/time.h may both be included" >&5
if eval "test \"`echo '$''{'ac_cv_header_time'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3107 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/time.h>
#include <time.h>
int main() {
struct tm *tp;
; return 0; }
EOF
if { (eval echo configure:3116: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_header_time=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_header_time=no
fi
rm -f conftest*
fi
echo "$ac_t""$ac_cv_header_time" 1>&6
if test $ac_cv_header_time = yes; then
cat >> confdefs.h <<\EOF
#define TIME_WITH_SYS_TIME 1
EOF
fi
echo $ac_n "checking for tm_zone in struct tm""... $ac_c" 1>&6
echo "configure:3137: checking for tm_zone in struct tm" >&5
if eval "test \"`echo '$''{'ac_cv_struct_tm_zone'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3142 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <$ac_cv_struct_tm>
int main() {
struct tm tm; tm.tm_zone;
; return 0; }
EOF
if { (eval echo configure:3150: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_tm_zone=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_struct_tm_zone=no
fi
rm -f conftest*
fi
echo "$ac_t""$ac_cv_struct_tm_zone" 1>&6
if test "$ac_cv_struct_tm_zone" = yes; then
cat >> confdefs.h <<\EOF
#define HAVE_TM_ZONE 1
EOF
else
echo $ac_n "checking for tzname""... $ac_c" 1>&6
echo "configure:3170: checking for tzname" >&5
if eval "test \"`echo '$''{'ac_cv_var_tzname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3175 "configure"
#include "confdefs.h"
#include <time.h>
#ifndef tzname /* For SGI. */
extern char *tzname[]; /* RS6000 and others reject char **tzname. */
#endif
int main() {
atoi(*tzname);
; return 0; }
EOF
if { (eval echo configure:3185: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
ac_cv_var_tzname=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_var_tzname=no
|
| ︙ | ︙ | |||
3193 3194 3195 3196 3197 3198 3199 |
fi
fi
for ac_func in gmtime_r localtime_r
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
| | | | 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 |
fi
fi
for ac_func in gmtime_r localtime_r
do
echo $ac_n "checking for $ac_func""... $ac_c" 1>&6
echo "configure:3210: checking for $ac_func" >&5
if eval "test \"`echo '$''{'ac_cv_func_$ac_func'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3215 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char $ac_func(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
3221 3222 3223 3224 3225 3226 3227 | choke me #else $ac_func(); #endif ; return 0; } EOF | | | 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 |
choke me
#else
$ac_func();
#endif
; return 0; }
EOF
if { (eval echo configure:3238: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_$ac_func=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_$ac_func=no"
|
| ︙ | ︙ | |||
3247 3248 3249 3250 3251 3252 3253 |
else
echo "$ac_t""no" 1>&6
fi
done
echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6
| | | | | | | | 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 |
else
echo "$ac_t""no" 1>&6
fi
done
echo $ac_n "checking tm_tzadj in struct tm""... $ac_c" 1>&6
echo "configure:3264: checking tm_tzadj in struct tm" >&5
if eval "test \"`echo '$''{'tcl_cv_member_tm_tzadj'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3269 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
struct tm tm; tm.tm_tzadj;
; return 0; }
EOF
if { (eval echo configure:3276: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_member_tm_tzadj=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_member_tm_tzadj=no
fi
rm -f conftest*
fi
echo "$ac_t""$tcl_cv_member_tm_tzadj" 1>&6
if test $tcl_cv_member_tm_tzadj = yes ; then
cat >> confdefs.h <<\EOF
#define HAVE_TM_TZADJ 1
EOF
fi
echo $ac_n "checking tm_gmtoff in struct tm""... $ac_c" 1>&6
echo "configure:3297: checking tm_gmtoff in struct tm" >&5
if eval "test \"`echo '$''{'tcl_cv_member_tm_gmtoff'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3302 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
struct tm tm; tm.tm_gmtoff;
; return 0; }
EOF
if { (eval echo configure:3309: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_member_tm_gmtoff=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_member_tm_gmtoff=no
|
| ︙ | ︙ | |||
3317 3318 3319 3320 3321 3322 3323 |
fi
#
# Its important to include time.h in this check, as some systems
# (like convex) have timezone functions, etc.
#
echo $ac_n "checking long timezone variable""... $ac_c" 1>&6
| | | | | 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 |
fi
#
# Its important to include time.h in this check, as some systems
# (like convex) have timezone functions, etc.
#
echo $ac_n "checking long timezone variable""... $ac_c" 1>&6
echo "configure:3334: checking long timezone variable" >&5
if eval "test \"`echo '$''{'tcl_cv_var_timezone'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3339 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
extern long timezone;
timezone += 1;
exit (0);
; return 0; }
EOF
if { (eval echo configure:3348: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_timezone_long=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_timezone_long=no
|
| ︙ | ︙ | |||
3354 3355 3356 3357 3358 3359 3360 |
EOF
else
#
# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
#
echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6
| | | | | 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 |
EOF
else
#
# On some systems (eg IRIX 6.2), timezone is a time_t and not a long.
#
echo $ac_n "checking time_t timezone variable""... $ac_c" 1>&6
echo "configure:3371: checking time_t timezone variable" >&5
if eval "test \"`echo '$''{'tcl_cv_timezone_time'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3376 "configure"
#include "confdefs.h"
#include <time.h>
int main() {
extern time_t timezone;
timezone += 1;
exit (0);
; return 0; }
EOF
if { (eval echo configure:3385: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_timezone_time=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_timezone_time=no
|
| ︙ | ︙ | |||
3395 3396 3397 3398 3399 3400 3401 | #-------------------------------------------------------------------- # Some systems (e.g., IRIX 4.0.5) lack the st_blksize field # in struct stat. But we might be able to use fstatfs instead. #-------------------------------------------------------------------- echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6 | | | | | | | 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 |
#--------------------------------------------------------------------
# Some systems (e.g., IRIX 4.0.5) lack the st_blksize field
# in struct stat. But we might be able to use fstatfs instead.
#--------------------------------------------------------------------
echo $ac_n "checking for st_blksize in struct stat""... $ac_c" 1>&6
echo "configure:3412: checking for st_blksize in struct stat" >&5
if eval "test \"`echo '$''{'ac_cv_struct_st_blksize'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3417 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/stat.h>
int main() {
struct stat s; s.st_blksize;
; return 0; }
EOF
if { (eval echo configure:3425: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
ac_cv_struct_st_blksize=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_struct_st_blksize=no
fi
rm -f conftest*
fi
echo "$ac_t""$ac_cv_struct_st_blksize" 1>&6
if test $ac_cv_struct_st_blksize = yes; then
cat >> confdefs.h <<\EOF
#define HAVE_ST_BLKSIZE 1
EOF
fi
echo $ac_n "checking for fstatfs""... $ac_c" 1>&6
echo "configure:3446: checking for fstatfs" >&5
if eval "test \"`echo '$''{'ac_cv_func_fstatfs'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3451 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char fstatfs(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
3457 3458 3459 3460 3461 3462 3463 | choke me #else fstatfs(); #endif ; return 0; } EOF | | | 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 |
choke me
#else
fstatfs();
#endif
; return 0; }
EOF
if { (eval echo configure:3474: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_fstatfs=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_fstatfs=no"
|
| ︙ | ︙ | |||
3486 3487 3488 3489 3490 3491 3492 | #-------------------------------------------------------------------- # Some system have no memcmp or it does not work with 8 bit # data, this checks it and add memcmp.o to LIBOBJS if needed #-------------------------------------------------------------------- echo $ac_n "checking for 8-bit clean memcmp""... $ac_c" 1>&6 | | | | | 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 |
#--------------------------------------------------------------------
# Some system have no memcmp or it does not work with 8 bit
# data, this checks it and add memcmp.o to LIBOBJS if needed
#--------------------------------------------------------------------
echo $ac_n "checking for 8-bit clean memcmp""... $ac_c" 1>&6
echo "configure:3503: checking for 8-bit clean memcmp" >&5
if eval "test \"`echo '$''{'ac_cv_func_memcmp_clean'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test "$cross_compiling" = yes; then
ac_cv_func_memcmp_clean=no
else
cat > conftest.$ac_ext <<EOF
#line 3511 "configure"
#include "confdefs.h"
main()
{
char c0 = 0x40, c1 = 0x80, c2 = 0x81;
exit(memcmp(&c0, &c2, 1) < 0 && memcmp(&c1, &c2, 1) < 0 ? 0 : 1);
}
EOF
if { (eval echo configure:3521: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
ac_cv_func_memcmp_clean=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
ac_cv_func_memcmp_clean=no
|
| ︙ | ︙ | |||
3528 3529 3530 3531 3532 3533 3534 |
#--------------------------------------------------------------------
# Some system like SunOS 4 and other BSD like systems
# have no memmove (we assume they have bcopy instead).
# {The replacement define is in compat/string.h}
#--------------------------------------------------------------------
echo $ac_n "checking for memmove""... $ac_c" 1>&6
| | | | 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 |
#--------------------------------------------------------------------
# Some system like SunOS 4 and other BSD like systems
# have no memmove (we assume they have bcopy instead).
# {The replacement define is in compat/string.h}
#--------------------------------------------------------------------
echo $ac_n "checking for memmove""... $ac_c" 1>&6
echo "configure:3545: checking for memmove" >&5
if eval "test \"`echo '$''{'ac_cv_func_memmove'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3550 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char memmove(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
3556 3557 3558 3559 3560 3561 3562 | choke me #else memmove(); #endif ; return 0; } EOF | | | 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 |
choke me
#else
memmove();
#endif
; return 0; }
EOF
if { (eval echo configure:3573: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_memmove=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_memmove=no"
|
| ︙ | ︙ | |||
3589 3590 3591 3592 3593 3594 3595 | #-------------------------------------------------------------------- # On some systems strstr is broken: it returns a pointer even # even if the original string is empty. #-------------------------------------------------------------------- echo $ac_n "checking proper strstr implementation""... $ac_c" 1>&6 | | | | | 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 |
#--------------------------------------------------------------------
# On some systems strstr is broken: it returns a pointer even
# even if the original string is empty.
#--------------------------------------------------------------------
echo $ac_n "checking proper strstr implementation""... $ac_c" 1>&6
echo "configure:3606: checking proper strstr implementation" >&5
if test "$cross_compiling" = yes; then
tcl_ok=no
else
cat > conftest.$ac_ext <<EOF
#line 3611 "configure"
#include "confdefs.h"
extern int strstr();
int main()
{
exit(strstr("\0test", "test") ? 1 : 0);
}
EOF
if { (eval echo configure:3621: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_ok=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_ok=no
|
| ︙ | ︙ | |||
3630 3631 3632 3633 3634 3635 3636 | #-------------------------------------------------------------------- # Check for strtoul function. This is tricky because under some # versions of AIX strtoul returns an incorrect terminator # pointer for the string "0". #-------------------------------------------------------------------- echo $ac_n "checking for strtoul""... $ac_c" 1>&6 | | | | 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 |
#--------------------------------------------------------------------
# Check for strtoul function. This is tricky because under some
# versions of AIX strtoul returns an incorrect terminator
# pointer for the string "0".
#--------------------------------------------------------------------
echo $ac_n "checking for strtoul""... $ac_c" 1>&6
echo "configure:3647: checking for strtoul" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtoul'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3652 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtoul(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
3658 3659 3660 3661 3662 3663 3664 | choke me #else strtoul(); #endif ; return 0; } EOF | | | 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 |
choke me
#else
strtoul();
#endif
; return 0; }
EOF
if { (eval echo configure:3675: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strtoul=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_strtoul=no"
|
| ︙ | ︙ | |||
3682 3683 3684 3685 3686 3687 3688 | tcl_ok=0 fi if test "$cross_compiling" = yes; then tcl_ok=0 else cat > conftest.$ac_ext <<EOF | | | | 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 |
tcl_ok=0
fi
if test "$cross_compiling" = yes; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
#line 3699 "configure"
#include "confdefs.h"
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);
}
EOF
if { (eval echo configure:3715: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
:
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_ok=0
|
| ︙ | ︙ | |||
3721 3722 3723 3724 3725 3726 3727 | #-------------------------------------------------------------------- # Check for the strtod function. This is tricky because in some # versions of Linux strtod mis-parses strings starting with "+". #-------------------------------------------------------------------- echo $ac_n "checking for strtod""... $ac_c" 1>&6 | | | | 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 |
#--------------------------------------------------------------------
# Check for the strtod function. This is tricky because in some
# versions of Linux strtod mis-parses strings starting with "+".
#--------------------------------------------------------------------
echo $ac_n "checking for strtod""... $ac_c" 1>&6
echo "configure:3738: checking for strtod" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3743 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtod(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
3749 3750 3751 3752 3753 3754 3755 | choke me #else strtod(); #endif ; return 0; } EOF | | | 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 |
choke me
#else
strtod();
#endif
; return 0; }
EOF
if { (eval echo configure:3766: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strtod=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_strtod=no"
|
| ︙ | ︙ | |||
3773 3774 3775 3776 3777 3778 3779 | tcl_ok=0 fi if test "$cross_compiling" = yes; then tcl_ok=0 else cat > conftest.$ac_ext <<EOF | | | | 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 |
tcl_ok=0
fi
if test "$cross_compiling" = yes; then
tcl_ok=0
else
cat > conftest.$ac_ext <<EOF
#line 3790 "configure"
#include "confdefs.h"
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);
}
EOF
if { (eval echo configure:3806: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
:
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_ok=0
|
| ︙ | ︙ | |||
3815 3816 3817 3818 3819 3820 3821 |
# terminating character under some conditions. Check for this
# and if the problem exists use a substitute procedure
# "fixstrtod" that corrects the error.
#--------------------------------------------------------------------
echo $ac_n "checking for strtod""... $ac_c" 1>&6
| | | | 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 |
# terminating character under some conditions. Check for this
# and if the problem exists use a substitute procedure
# "fixstrtod" that corrects the error.
#--------------------------------------------------------------------
echo $ac_n "checking for strtod""... $ac_c" 1>&6
echo "configure:3832: checking for strtod" >&5
if eval "test \"`echo '$''{'ac_cv_func_strtod'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3837 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strtod(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
3843 3844 3845 3846 3847 3848 3849 | choke me #else strtod(); #endif ; return 0; } EOF | | | 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 |
choke me
#else
strtod();
#endif
; return 0; }
EOF
if { (eval echo configure:3860: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strtod=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_strtod=no"
|
| ︙ | ︙ | |||
3865 3866 3867 3868 3869 3870 3871 |
else
echo "$ac_t""no" 1>&6
tcl_strtod=0
fi
if test "$tcl_strtod" = 1; then
echo $ac_n "checking for Solaris2.4/Tru64 strtod bugs""... $ac_c" 1>&6
| | > > > > | | | | | < | | | | | | | > > > > | | | | | | | | | > > | | | | | | | | | 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 |
else
echo "$ac_t""no" 1>&6
tcl_strtod=0
fi
if test "$tcl_strtod" = 1; then
echo $ac_n "checking for Solaris2.4/Tru64 strtod bugs""... $ac_c" 1>&6
echo "configure:3882: checking for Solaris2.4/Tru64 strtod bugs" >&5
if eval "test \"`echo '$''{'tcl_cv_strtod_buggy'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test "$cross_compiling" = yes; then
tcl_cv_strtod_buggy=0
else
cat > conftest.$ac_ext <<EOF
#line 3891 "configure"
#include "confdefs.h"
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);
}
EOF
if { (eval echo configure:3914: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
tcl_cv_strtod_buggy=1
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
tcl_cv_strtod_buggy=0
fi
rm -fr conftest*
fi
fi
if test "$tcl_cv_strtod_buggy" = 1; then
echo "$ac_t""ok" 1>&6
else
echo "$ac_t""buggy" 1>&6
LIBOBJS="$LIBOBJS fixstrtod.o"
cat >> confdefs.h <<\EOF
#define strtod fixstrtod
EOF
fi
fi
#--------------------------------------------------------------------
# Check for various typedefs and provide substitutes if
# they don't exist.
#--------------------------------------------------------------------
echo $ac_n "checking for ANSI C header files""... $ac_c" 1>&6
echo "configure:3947: checking for ANSI C header files" >&5
if eval "test \"`echo '$''{'ac_cv_header_stdc'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 3952 "configure"
#include "confdefs.h"
#include <stdlib.h>
#include <stdarg.h>
#include <string.h>
#include <float.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:3960: \"$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*
ac_cv_header_stdc=yes
else
echo "$ac_err" >&5
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
ac_cv_header_stdc=no
fi
rm -f conftest*
if test $ac_cv_header_stdc = yes; then
# SunOS 4.x string.h does not declare mem*, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
#line 3977 "configure"
#include "confdefs.h"
#include <string.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "memchr" >/dev/null 2>&1; then
:
else
rm -rf conftest*
ac_cv_header_stdc=no
fi
rm -f conftest*
fi
if test $ac_cv_header_stdc = yes; then
# ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI.
cat > conftest.$ac_ext <<EOF
#line 3995 "configure"
#include "confdefs.h"
#include <stdlib.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "free" >/dev/null 2>&1; then
:
else
rm -rf conftest*
ac_cv_header_stdc=no
fi
rm -f conftest*
fi
if test $ac_cv_header_stdc = yes; then
# /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi.
if test "$cross_compiling" = yes; then
:
else
cat > conftest.$ac_ext <<EOF
#line 4016 "configure"
#include "confdefs.h"
#include <ctype.h>
#define ISLOWER(c) ('a' <= (c) && (c) <= 'z')
#define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c))
#define XOR(e, f) (((e) && !(f)) || (!(e) && (f)))
int main () { int i; for (i = 0; i < 256; i++)
if (XOR (islower (i), ISLOWER (i)) || toupper (i) != TOUPPER (i)) exit(2);
exit (0); }
EOF
if { (eval echo configure:4027: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
:
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
ac_cv_header_stdc=no
|
| ︙ | ︙ | |||
4025 4026 4027 4028 4029 4030 4031 | cat >> confdefs.h <<\EOF #define STDC_HEADERS 1 EOF fi echo $ac_n "checking for mode_t""... $ac_c" 1>&6 | | | | 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 |
cat >> confdefs.h <<\EOF
#define STDC_HEADERS 1
EOF
fi
echo $ac_n "checking for mode_t""... $ac_c" 1>&6
echo "configure:4051: checking for mode_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_mode_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4056 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF
|
| ︙ | ︙ | |||
4058 4059 4060 4061 4062 4063 4064 | cat >> confdefs.h <<\EOF #define mode_t int EOF fi echo $ac_n "checking for pid_t""... $ac_c" 1>&6 | | | | 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 |
cat >> confdefs.h <<\EOF
#define mode_t int
EOF
fi
echo $ac_n "checking for pid_t""... $ac_c" 1>&6
echo "configure:4084: checking for pid_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_pid_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4089 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF
|
| ︙ | ︙ | |||
4091 4092 4093 4094 4095 4096 4097 | cat >> confdefs.h <<\EOF #define pid_t int EOF fi echo $ac_n "checking for size_t""... $ac_c" 1>&6 | | | | 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 |
cat >> confdefs.h <<\EOF
#define pid_t int
EOF
fi
echo $ac_n "checking for size_t""... $ac_c" 1>&6
echo "configure:4117: checking for size_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_size_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4122 "configure"
#include "confdefs.h"
#include <sys/types.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF
|
| ︙ | ︙ | |||
4124 4125 4126 4127 4128 4129 4130 | cat >> confdefs.h <<\EOF #define size_t unsigned EOF fi echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6 | | | | 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 |
cat >> confdefs.h <<\EOF
#define size_t unsigned
EOF
fi
echo $ac_n "checking for uid_t in sys/types.h""... $ac_c" 1>&6
echo "configure:4150: checking for uid_t in sys/types.h" >&5
if eval "test \"`echo '$''{'ac_cv_type_uid_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4155 "configure"
#include "confdefs.h"
#include <sys/types.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "uid_t" >/dev/null 2>&1; then
rm -rf conftest*
ac_cv_type_uid_t=yes
|
| ︙ | ︙ | |||
4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 | cat >> confdefs.h <<\EOF #define gid_t int EOF 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 # is compatible with the substitute version of opendir that's # provided. This version only works with V7-style directories. #-------------------------------------------------------------------- echo $ac_n "checking for opendir""... $ac_c" 1>&6 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 |
cat >> confdefs.h <<\EOF
#define gid_t int
EOF
fi
echo $ac_n "checking for socklen_t""... $ac_c" 1>&6
echo "configure:4185: checking for socklen_t" >&5
if eval "test \"`echo '$''{'ac_cv_type_socklen_t'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4190 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/socket.h>
#if STDC_HEADERS
#include <stdlib.h>
#include <stddef.h>
#endif
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "(^|[^a-zA-Z_0-9])socklen_t[^a-zA-Z_0-9]" >/dev/null 2>&1; then
rm -rf conftest*
ac_cv_type_socklen_t=yes
else
rm -rf conftest*
ac_cv_type_socklen_t=no
fi
rm -f conftest*
echo "$ac_t""$ac_cv_type_socklen_t" 1>&6
if test $ac_cv_type_socklen_t = no; then
cat >> confdefs.h <<\EOF
#define socklen_t unsigned
EOF
fi
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
# is compatible with the substitute version of opendir that's
# provided. This version only works with V7-style directories.
#--------------------------------------------------------------------
echo $ac_n "checking for opendir""... $ac_c" 1>&6
echo "configure:4228: checking for opendir" >&5
if eval "test \"`echo '$''{'ac_cv_func_opendir'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4233 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char opendir(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
4194 4195 4196 4197 4198 4199 4200 | choke me #else opendir(); #endif ; return 0; } EOF | | | 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 |
choke me
#else
opendir();
#endif
; return 0; }
EOF
if { (eval echo configure:4256: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_opendir=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_opendir=no"
|
| ︙ | ︙ | |||
4227 4228 4229 4230 4231 4232 4233 | # "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. #-------------------------------------------------------------------- echo $ac_n "checking union wait""... $ac_c" 1>&6 | | | | | 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 |
# "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.
#--------------------------------------------------------------------
echo $ac_n "checking union wait""... $ac_c" 1>&6
echo "configure:4289: checking union wait" >&5
if eval "test \"`echo '$''{'tcl_cv_union_wait'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4294 "configure"
#include "confdefs.h"
#include <sys/types.h>
#include <sys/wait.h>
int main() {
union wait x;
WIFEXITED(x); /* Generates compiler error if WIFEXITED
* uses an int. */
; return 0; }
EOF
if { (eval echo configure:4306: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
tcl_cv_union_wait=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_union_wait=no
|
| ︙ | ︙ | |||
4271 4272 4273 4274 4275 4276 4277 | #-------------------------------------------------------------------- # Check whether there is an strncasecmp function on this system. # This is a bit tricky because under SCO it's in -lsocket and # under Sequent Dynix it's in -linet. #-------------------------------------------------------------------- echo $ac_n "checking for strncasecmp""... $ac_c" 1>&6 | | | | 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 |
#--------------------------------------------------------------------
# Check whether there is an strncasecmp function on this system.
# This is a bit tricky because under SCO it's in -lsocket and
# under Sequent Dynix it's in -linet.
#--------------------------------------------------------------------
echo $ac_n "checking for strncasecmp""... $ac_c" 1>&6
echo "configure:4333: checking for strncasecmp" >&5
if eval "test \"`echo '$''{'ac_cv_func_strncasecmp'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4338 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char strncasecmp(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
4299 4300 4301 4302 4303 4304 4305 | choke me #else strncasecmp(); #endif ; return 0; } EOF | | | 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 |
choke me
#else
strncasecmp();
#endif
; return 0; }
EOF
if { (eval echo configure:4361: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_strncasecmp=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_strncasecmp=no"
|
| ︙ | ︙ | |||
4321 4322 4323 4324 4325 4326 4327 |
else
echo "$ac_t""no" 1>&6
tcl_ok=0
fi
if test "$tcl_ok" = 0; then
echo $ac_n "checking for strncasecmp in -lsocket""... $ac_c" 1>&6
| | | | | 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 |
else
echo "$ac_t""no" 1>&6
tcl_ok=0
fi
if test "$tcl_ok" = 0; then
echo $ac_n "checking for strncasecmp in -lsocket""... $ac_c" 1>&6
echo "configure:4383: checking for strncasecmp in -lsocket" >&5
ac_lib_var=`echo socket'_'strncasecmp | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lsocket $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4391 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char strncasecmp();
int main() {
strncasecmp()
; return 0; }
EOF
if { (eval echo configure:4402: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
4364 4365 4366 4367 4368 4369 4370 |
echo "$ac_t""no" 1>&6
tcl_ok=0
fi
fi
if test "$tcl_ok" = 0; then
echo $ac_n "checking for strncasecmp in -linet""... $ac_c" 1>&6
| | | | | 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 |
echo "$ac_t""no" 1>&6
tcl_ok=0
fi
fi
if test "$tcl_ok" = 0; then
echo $ac_n "checking for strncasecmp in -linet""... $ac_c" 1>&6
echo "configure:4426: checking for strncasecmp in -linet" >&5
ac_lib_var=`echo inet'_'strncasecmp | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-linet $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4434 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char strncasecmp();
int main() {
strncasecmp()
; return 0; }
EOF
if { (eval echo configure:4445: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
4421 4422 4423 4424 4425 4426 4427 | # but they have a BSDgettimeofday function that can be used instead. # 3. See if gettimeofday is declared in the <sys/time.h> header file. # if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can # declare it. #-------------------------------------------------------------------- echo $ac_n "checking for BSDgettimeofday""... $ac_c" 1>&6 | | | | 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 |
# but they have a BSDgettimeofday function that can be used instead.
# 3. See if gettimeofday is declared in the <sys/time.h> header file.
# if not, set the GETTOD_NOT_DECLARED flag so that tclPort.h can
# declare it.
#--------------------------------------------------------------------
echo $ac_n "checking for BSDgettimeofday""... $ac_c" 1>&6
echo "configure:4483: checking for BSDgettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_BSDgettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4488 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char BSDgettimeofday(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
4449 4450 4451 4452 4453 4454 4455 | choke me #else BSDgettimeofday(); #endif ; return 0; } EOF | | | 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 |
choke me
#else
BSDgettimeofday();
#endif
; return 0; }
EOF
if { (eval echo configure:4511: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_BSDgettimeofday=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_BSDgettimeofday=no"
|
| ︙ | ︙ | |||
4471 4472 4473 4474 4475 4476 4477 |
#define HAVE_BSDGETTIMEOFDAY 1
EOF
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6
| | | | 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 |
#define HAVE_BSDGETTIMEOFDAY 1
EOF
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for gettimeofday""... $ac_c" 1>&6
echo "configure:4533: checking for gettimeofday" >&5
if eval "test \"`echo '$''{'ac_cv_func_gettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4538 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gettimeofday(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
4499 4500 4501 4502 4503 4504 4505 | choke me #else gettimeofday(); #endif ; return 0; } EOF | | | 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 |
choke me
#else
gettimeofday();
#endif
; return 0; }
EOF
if { (eval echo configure:4561: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_gettimeofday=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_gettimeofday=no"
|
| ︙ | ︙ | |||
4526 4527 4528 4529 4530 4531 4532 | fi fi echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6 | | | | 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 |
fi
fi
echo $ac_n "checking for gettimeofday declaration""... $ac_c" 1>&6
echo "configure:4588: checking for gettimeofday declaration" >&5
if eval "test \"`echo '$''{'tcl_cv_grep_gettimeofday'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4593 "configure"
#include "confdefs.h"
#include <sys/time.h>
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
egrep "gettimeofday" >/dev/null 2>&1; then
rm -rf conftest*
tcl_cv_grep_gettimeofday=present
|
| ︙ | ︙ | |||
4562 4563 4564 4565 4566 4567 4568 | #-------------------------------------------------------------------- # 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. #-------------------------------------------------------------------- echo $ac_n "checking whether char is unsigned""... $ac_c" 1>&6 | | | | 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 |
#--------------------------------------------------------------------
# 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.
#--------------------------------------------------------------------
echo $ac_n "checking whether char is unsigned""... $ac_c" 1>&6
echo "configure:4624: checking whether char is unsigned" >&5
if eval "test \"`echo '$''{'ac_cv_c_char_unsigned'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
if test "$GCC" = yes; then
# GCC predefines this symbol on systems where it applies.
cat > conftest.$ac_ext <<EOF
#line 4631 "configure"
#include "confdefs.h"
#ifdef __CHAR_UNSIGNED__
yes
#endif
EOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
|
| ︙ | ︙ | |||
4591 4592 4593 4594 4595 4596 4597 |
rm -f conftest*
else
if test "$cross_compiling" = yes; then
{ echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
cat > conftest.$ac_ext <<EOF
| | | | 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 |
rm -f conftest*
else
if test "$cross_compiling" = yes; then
{ echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
cat > conftest.$ac_ext <<EOF
#line 4653 "configure"
#include "confdefs.h"
/* volatile prevents gcc2 from optimizing the test away on sparcs. */
#if !defined(__STDC__) || __STDC__ != 1
#define volatile
#endif
main() {
volatile char c = 255; exit(c < 0);
}
EOF
if { (eval echo configure:4663: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext} && (./conftest; exit) 2>/dev/null
then
ac_cv_c_char_unsigned=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -fr conftest*
ac_cv_c_char_unsigned=no
|
| ︙ | ︙ | |||
4625 4626 4627 4628 4629 4630 4631 | cat >> confdefs.h <<\EOF #define __CHAR_UNSIGNED__ 1 EOF fi echo $ac_n "checking signed char declarations""... $ac_c" 1>&6 | | | | | 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 |
cat >> confdefs.h <<\EOF
#define __CHAR_UNSIGNED__ 1
EOF
fi
echo $ac_n "checking signed char declarations""... $ac_c" 1>&6
echo "configure:4687: checking signed char declarations" >&5
if eval "test \"`echo '$''{'tcl_cv_char_signed'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4692 "configure"
#include "confdefs.h"
int main() {
signed char *p;
p = 0;
; return 0; }
EOF
if { (eval echo configure:4702: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_cv_char_signed=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_cv_char_signed=no
|
| ︙ | ︙ | |||
4679 4680 4681 4682 4683 4684 4685 |
HAVE_LANGINFO=0
if test "$langinfo_ok" = "yes"; then
if test "$langinfo_ok" = "yes"; then
ac_safe=`echo "langinfo.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for langinfo.h""... $ac_c" 1>&6
| | | | | 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 |
HAVE_LANGINFO=0
if test "$langinfo_ok" = "yes"; then
if test "$langinfo_ok" = "yes"; then
ac_safe=`echo "langinfo.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for langinfo.h""... $ac_c" 1>&6
echo "configure:4741: checking for langinfo.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 4746 "configure"
#include "confdefs.h"
#include <langinfo.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:4751: \"$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
|
| ︙ | ︙ | |||
4714 4715 4716 4717 4718 4719 4720 |
echo "$ac_t""no" 1>&6
langinfo_ok=no
fi
fi
fi
echo $ac_n "checking whether to use nl_langinfo""... $ac_c" 1>&6
| | | | | 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 |
echo "$ac_t""no" 1>&6
langinfo_ok=no
fi
fi
fi
echo $ac_n "checking whether to use nl_langinfo""... $ac_c" 1>&6
echo "configure:4776: checking whether to use nl_langinfo" >&5
if test "$langinfo_ok" = "yes"; then
cat > conftest.$ac_ext <<EOF
#line 4779 "configure"
#include "confdefs.h"
#include <langinfo.h>
int main() {
nl_langinfo(CODESET);
; return 0; }
EOF
if { (eval echo configure:4786: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
langinfo_ok=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
langinfo_ok=no
|
| ︙ | ︙ | |||
4760 4761 4762 4763 4764 4765 4766 |
# 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").
#--------------------------------------------------------------------
echo $ac_n "checking for sin""... $ac_c" 1>&6
| | | | 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 |
# 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").
#--------------------------------------------------------------------
echo $ac_n "checking for sin""... $ac_c" 1>&6
echo "configure:4822: checking for sin" >&5
if eval "test \"`echo '$''{'ac_cv_func_sin'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 4827 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char sin(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
4788 4789 4790 4791 4792 4793 4794 | choke me #else sin(); #endif ; return 0; } EOF | | | | | | 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 |
choke me
#else
sin();
#endif
; return 0; }
EOF
if { (eval echo configure:4850: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_sin=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_sin=no"
fi
rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_func_'sin`\" = yes"; then
echo "$ac_t""yes" 1>&6
MATH_LIBS=""
else
echo "$ac_t""no" 1>&6
MATH_LIBS="-lm"
fi
echo $ac_n "checking for main in -lieee""... $ac_c" 1>&6
echo "configure:4871: checking for main in -lieee" >&5
ac_lib_var=`echo ieee'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lieee $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4879 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
if { (eval echo configure:4886: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
4851 4852 4853 4854 4855 4856 4857 |
#--------------------------------------------------------------------
# Interactive UNIX requires -linet instead of -lsocket, plus it
# needs net/errno.h to define the socket-related error codes.
#--------------------------------------------------------------------
echo $ac_n "checking for main in -linet""... $ac_c" 1>&6
| | | | | 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 |
#--------------------------------------------------------------------
# Interactive UNIX requires -linet instead of -lsocket, plus it
# needs net/errno.h to define the socket-related error codes.
#--------------------------------------------------------------------
echo $ac_n "checking for main in -linet""... $ac_c" 1>&6
echo "configure:4913: checking for main in -linet" >&5
ac_lib_var=`echo inet'_'main | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-linet $LIBS"
cat > conftest.$ac_ext <<EOF
#line 4921 "configure"
#include "confdefs.h"
int main() {
main()
; return 0; }
EOF
if { (eval echo configure:4928: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
4888 4889 4890 4891 4892 4893 4894 |
LIBS="$LIBS -linet"
else
echo "$ac_t""no" 1>&6
fi
ac_safe=`echo "net/errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for net/errno.h""... $ac_c" 1>&6
| | | | | 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 |
LIBS="$LIBS -linet"
else
echo "$ac_t""no" 1>&6
fi
ac_safe=`echo "net/errno.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for net/errno.h""... $ac_c" 1>&6
echo "configure:4950: checking for net/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 4955 "configure"
#include "confdefs.h"
#include <net/errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:4960: \"$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
|
| ︙ | ︙ | |||
4943 4944 4945 4946 4947 4948 4949 |
# 4. On some SVR4 systems, can't use -lsocket without -lnsl too.
# To get around this problem, check for both libraries together
# if -lsocket doesn't work by itself.
#--------------------------------------------------------------------
tcl_checkBoth=0
echo $ac_n "checking for connect""... $ac_c" 1>&6
| | | | 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 |
# 4. On some SVR4 systems, can't use -lsocket without -lnsl too.
# To get around this problem, check for both libraries together
# if -lsocket doesn't work by itself.
#--------------------------------------------------------------------
tcl_checkBoth=0
echo $ac_n "checking for connect""... $ac_c" 1>&6
echo "configure:5005: checking for connect" >&5
if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 5010 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char connect(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
4971 4972 4973 4974 4975 4976 4977 | choke me #else connect(); #endif ; return 0; } EOF | | | 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 |
choke me
#else
connect();
#endif
; return 0; }
EOF
if { (eval echo configure:5033: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_connect=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_connect=no"
|
| ︙ | ︙ | |||
4993 4994 4995 4996 4997 4998 4999 |
else
echo "$ac_t""no" 1>&6
tcl_checkSocket=1
fi
if test "$tcl_checkSocket" = 1; then
echo $ac_n "checking for setsockopt""... $ac_c" 1>&6
| | | | 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 |
else
echo "$ac_t""no" 1>&6
tcl_checkSocket=1
fi
if test "$tcl_checkSocket" = 1; then
echo $ac_n "checking for setsockopt""... $ac_c" 1>&6
echo "configure:5055: checking for setsockopt" >&5
if eval "test \"`echo '$''{'ac_cv_func_setsockopt'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 5060 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char setsockopt(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
5021 5022 5023 5024 5025 5026 5027 | choke me #else setsockopt(); #endif ; return 0; } EOF | | | | | | 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 |
choke me
#else
setsockopt();
#endif
; return 0; }
EOF
if { (eval echo configure:5083: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_setsockopt=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_setsockopt=no"
fi
rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_func_'setsockopt`\" = yes"; then
echo "$ac_t""yes" 1>&6
:
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for setsockopt in -lsocket""... $ac_c" 1>&6
echo "configure:5101: checking for setsockopt in -lsocket" >&5
ac_lib_var=`echo socket'_'setsockopt | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lsocket $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5109 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char setsockopt();
int main() {
setsockopt()
; return 0; }
EOF
if { (eval echo configure:5120: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
5086 5087 5088 5089 5090 5091 5092 |
fi
fi
if test "$tcl_checkBoth" = 1; then
tk_oldLibs=$LIBS
LIBS="$LIBS -lsocket -lnsl"
echo $ac_n "checking for accept""... $ac_c" 1>&6
| | | | 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 |
fi
fi
if test "$tcl_checkBoth" = 1; then
tk_oldLibs=$LIBS
LIBS="$LIBS -lsocket -lnsl"
echo $ac_n "checking for accept""... $ac_c" 1>&6
echo "configure:5148: checking for accept" >&5
if eval "test \"`echo '$''{'ac_cv_func_accept'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 5153 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char accept(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
5114 5115 5116 5117 5118 5119 5120 | choke me #else accept(); #endif ; return 0; } EOF | | | 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 |
choke me
#else
accept();
#endif
; return 0; }
EOF
if { (eval echo configure:5176: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_accept=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_accept=no"
|
| ︙ | ︙ | |||
5136 5137 5138 5139 5140 5141 5142 |
else
echo "$ac_t""no" 1>&6
LIBS=$tk_oldLibs
fi
fi
echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
| | | | 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 |
else
echo "$ac_t""no" 1>&6
LIBS=$tk_oldLibs
fi
fi
echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
echo "configure:5198: checking for gethostbyname" >&5
if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 5203 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gethostbyname(); below. */
#include <assert.h>
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
|
| ︙ | ︙ | |||
5164 5165 5166 5167 5168 5169 5170 | choke me #else gethostbyname(); #endif ; return 0; } EOF | | | | | | 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 |
choke me
#else
gethostbyname();
#endif
; return 0; }
EOF
if { (eval echo configure:5226: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_func_gethostbyname=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_func_gethostbyname=no"
fi
rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_func_'gethostbyname`\" = yes"; then
echo "$ac_t""yes" 1>&6
:
else
echo "$ac_t""no" 1>&6
echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6
echo "configure:5244: checking for gethostbyname in -lnsl" >&5
ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lnsl $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5252 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char gethostbyname();
int main() {
gethostbyname()
; return 0; }
EOF
if { (eval echo configure:5263: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 |
# Add the threads support libraries
LIBS="$LIBS$THREADS_LIBS"
#--------------------------------------------------------------------
# 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.
#--------------------------------------------------------------------
# Step 0.a: Enable 64 bit support?
echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 |
# Add the threads support libraries
LIBS="$LIBS$THREADS_LIBS"
echo $ac_n "checking how to build libraries""... $ac_c" 1>&6
echo "configure:5300: 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
if test "${enable_shared+set}" = set; then
enableval="$enable_shared"
tcl_ok=$enableval
else
tcl_ok=yes
fi
if test "$tcl_ok" = "yes" ; then
echo "$ac_t""shared" 1>&6
SHARED_BUILD=1
else
echo "$ac_t""static" 1>&6
SHARED_BUILD=0
cat >> confdefs.h <<\EOF
#define STATIC_BUILD 1
EOF
fi
#--------------------------------------------------------------------
# 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.
#--------------------------------------------------------------------
# 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:5339: 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=":"
ac_dummy="$PATH"
for ac_dir in $ac_dummy; do
test -z "$ac_dir" && ac_dir=.
if test -f $ac_dir/$ac_word; then
ac_cv_prog_RANLIB="ranlib"
break
fi
done
IFS="$ac_save_ifs"
test -z "$ac_cv_prog_RANLIB" && ac_cv_prog_RANLIB=":"
fi
fi
RANLIB="$ac_cv_prog_RANLIB"
if test -n "$RANLIB"; then
echo "$ac_t""$RANLIB" 1>&6
else
echo "$ac_t""no" 1>&6
fi
# Step 0.a: Enable 64 bit support?
echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
echo "configure:5371: 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"
:
else
enableval="no"
fi
if test "$enableval" = "yes"; then
do64bit=yes
else
do64bit=no
fi
echo "$ac_t""$do64bit" 1>&6
# Step 0.b: Enable Solaris 64 bit VIS support?
echo $ac_n "checking if 64bit Sparc VIS support is requested""... $ac_c" 1>&6
echo "configure:5391: checking if 64bit Sparc VIS support is requested" >&5
# Check whether --enable-64bit-vis or --disable-64bit-vis was given.
if test "${enable_64bit_vis+set}" = set; then
enableval="$enable_64bit_vis"
:
else
enableval="no"
fi
|
| ︙ | ︙ | |||
5291 5292 5293 5294 5295 5296 5297 |
echo "$ac_t""$do64bitVIS" 1>&6
# Step 1: set the variable "system" to hold the name and version number
# for the system. This can usually be done via the "uname" command, but
# there are a few systems, like Next, where this doesn't work.
echo $ac_n "checking system version (for dynamic loading)""... $ac_c" 1>&6
| | | 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 |
echo "$ac_t""$do64bitVIS" 1>&6
# Step 1: set the variable "system" to hold the name and version number
# for the system. This can usually be done via the "uname" command, but
# there are a few systems, like Next, where this doesn't work.
echo $ac_n "checking system version (for dynamic loading)""... $ac_c" 1>&6
echo "configure:5415: checking system version (for dynamic loading)" >&5
if test -f /usr/lib/NextStep/software_version; then
system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
else
system=`uname -s`-`uname -r`
if test "$?" -ne 0 ; then
echo "$ac_t""unknown (can't find uname command)" 1>&6
system=unknown
|
| ︙ | ︙ | |||
5317 5318 5319 5320 5321 5322 5323 |
fi
fi
# Step 2: check for existence of -ldl library. This is needed because
# Linux can use either -ldl or -ldld for dynamic loading.
echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
| | | | | 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 |
fi
fi
# Step 2: check for existence of -ldl library. This is needed because
# Linux can use either -ldl or -ldld for dynamic loading.
echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
echo "configure:5441: checking for dlopen in -ldl" >&5
ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-ldl $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5449 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char dlopen();
int main() {
dlopen()
; return 0; }
EOF
if { (eval echo configure:5460: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
5380 5381 5382 5383 5384 5385 5386 |
fi
TCL_NEEDS_EXP_FILE=0
TCL_BUILD_EXP_FILE=""
TCL_EXP_FILE=""
# 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
| | | 5496 5497 5498 5499 5500 5501 5502 5503 5504 5505 5506 5507 5508 5509 5510 |
fi
TCL_NEEDS_EXP_FILE=0
TCL_BUILD_EXP_FILE=""
TCL_EXP_FILE=""
# 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:5504: 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=":"
|
| ︙ | ︙ | |||
5432 5433 5434 5435 5436 5437 5438 5439 |
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# AIX-5 has dl* in libc.so
DL_LIBS=""
LDFLAGS=""
if test "$GCC" = "yes" ; then
| > | | > | 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 5558 5559 5560 5561 5562 5563 5564 5565 5566 5567 5568 |
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# AIX-5 has dl* in libc.so
DL_LIBS=""
LDFLAGS=""
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}'
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = "yes" ; then
if test "$GCC" = "yes" ; then
echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
else
do64bit_ok=yes
|
| ︙ | ︙ | |||
5465 5466 5467 5468 5469 5470 5471 |
SHLIB_CFLAGS=""
SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
| | > | 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 |
SHLIB_CFLAGS=""
SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
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'
# 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"
|
| ︙ | ︙ | |||
5488 5489 5490 5491 5492 5493 5494 | # AIX does not have a timezone field in struct tm. When the AIX # bsd library is used, the timezone global and the gettimeofday # methods are to be avoided for timezone deduction instead, we # deduce the timezone by comparing the localtime result on a # known GMT value. echo $ac_n "checking for gettimeofday in -lbsd""... $ac_c" 1>&6 | | | | | 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 |
# AIX does not have a timezone field in struct tm. When the AIX
# bsd library is used, the timezone global and the gettimeofday
# methods are to be avoided for timezone deduction instead, we
# deduce the timezone by comparing the localtime result on a
# known GMT value.
echo $ac_n "checking for gettimeofday in -lbsd""... $ac_c" 1>&6
echo "configure:5615: checking for gettimeofday in -lbsd" >&5
ac_lib_var=`echo bsd'_'gettimeofday | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-lbsd $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5623 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char gettimeofday();
int main() {
gettimeofday()
; return 0; }
EOF
if { (eval echo configure:5634: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
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 |
SHLIB_CFLAGS=""
SHLIB_LD="shlicc -r"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
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="-export-dynamic"
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"
LDFLAGS=""
LD_SEARCH_FLAGS=""
;;
HP-UX-*.11.*)
# Use updated header definitions where possible
cat >> confdefs.h <<\EOF
#define _XOPEN_SOURCE_EXTENDED 1
EOF
SHLIB_SUFFIX=".sl"
echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
| > > > | | | | 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 |
SHLIB_CFLAGS=""
SHLIB_LD="shlicc -r"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
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="-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"
LDFLAGS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
HP-UX-*.11.*)
# Use updated header definitions where possible
cat >> confdefs.h <<\EOF
#define _XOPEN_SOURCE_EXTENDED 1
EOF
SHLIB_SUFFIX=".sl"
echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
echo "configure:5716: checking for shl_load in -ldld" >&5
ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-ldld $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5724 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char shl_load();
int main() {
shl_load()
; return 0; }
EOF
if { (eval echo configure:5735: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
5633 5634 5635 5636 5637 5638 5639 |
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="-Wl,-E"
| | > | | | | 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 |
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="-Wl,-E"
CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
fi
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = "yes" ; then
if test "$GCC" = "yes" ; then
echo "configure: warning: "64bit mode not supported with GCC on $system"" 1>&2
else
do64bit_ok=yes
EXTRA_CFLAGS="+DA2.0W"
LDFLAGS="+DA2.0W $LDFLAGS"
fi
fi
;;
HP-UX-*.08.*|HP-UX-*.09.*|HP-UX-*.10.*)
SHLIB_SUFFIX=".sl"
echo $ac_n "checking for shl_load in -ldld""... $ac_c" 1>&6
echo "configure:5781: checking for shl_load in -ldld" >&5
ac_lib_var=`echo dld'_'shl_load | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
ac_save_LIBS="$LIBS"
LIBS="-ldld $LIBS"
cat > conftest.$ac_ext <<EOF
#line 5789 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
builtin and then its argument prototype would still apply. */
char shl_load();
int main() {
shl_load()
; return 0; }
EOF
if { (eval echo configure:5800: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=no"
|
| ︙ | ︙ | |||
5697 5698 5699 5700 5701 5702 5703 | if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="-Wl,-E" | | > | > | > | > | 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 |
if test "$tcl_ok" = yes; then
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
SHLIB_LD_LIBS=""
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="-Wl,-E"
CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
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="-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}'
EXTRA_CFLAGS=""
LDFLAGS=""
;;
IRIX-6.*|IRIX64-6.5*)
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
EXTRA_CFLAGS="-mabi=n32"
LDFLAGS="-mabi=n32"
else
case $system in
IRIX-6.3)
# Use to build 6.2 compatible binaries on 6.3.
|
| ︙ | ︙ | |||
5754 5755 5756 5757 5758 5759 5760 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
| | > > > > > > > > > > > > > > > | > | | | > | 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 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
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
echo "configure: warning: 64bit mode not supported by gcc" 1>&2
else
do64bit_ok=yes
SHLIB_LD="ld -64 -shared -rdata_shared"
EXTRA_CFLAGS="-64"
LDFLAGS="-64"
fi
fi
;;
Linux*)
SHLIB_CFLAGS="-fPIC"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
# 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"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="-rdynamic"
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
else
ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dld.h""... $ac_c" 1>&6
echo "configure:5927: checking for dld.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 5932 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:5937: \"$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
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_header_$ac_safe=no"
fi
rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
echo "$ac_t""yes" 1>&6
SHLIB_LD="ld -shared"
DL_OBJS="tclLoadDld.o"
DL_LIBS="-ldld"
LDFLAGS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
else
echo "$ac_t""no" 1>&6
fi
fi
if test "`uname -m`" = "alpha" ; then
|
| ︙ | ︙ | |||
5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 |
SHLIB_SUFFIX=".so"
if test "$have_dl" = yes; then
SHLIB_LD="${CC} -shared"
DL_OBJS=""
DL_LIBS="-ldl"
LDFLAGS="-rdynamic"
LD_SEARCH_FLAGS=""
else
ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dld.h""... $ac_c" 1>&6
| > | | | > > > | | | | 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 |
SHLIB_SUFFIX=".so"
if test "$have_dl" = yes; then
SHLIB_LD="${CC} -shared"
DL_OBJS=""
DL_LIBS="-ldl"
LDFLAGS="-rdynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
else
ac_safe=`echo "dld.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dld.h""... $ac_c" 1>&6
echo "configure:5996: checking for dld.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 6001 "configure"
#include "confdefs.h"
#include <dld.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6006: \"$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
cat conftest.$ac_ext >&5
rm -rf conftest*
eval "ac_cv_header_$ac_safe=no"
fi
rm -f conftest*
fi
if eval "test \"`echo '$ac_cv_header_'$ac_safe`\" = yes"; then
echo "$ac_t""yes" 1>&6
SHLIB_LD="ld -shared"
DL_OBJS=""
DL_LIBS="-ldld"
LDFLAGS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
else
echo "$ac_t""no" 1>&6
fi
fi
if test "`uname -m`" = "alpha" ; then
EXTRA_CFLAGS="-mieee"
fi
;;
MP-RAS-02*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
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="-Wl,-Bexport"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
NetBSD-*|FreeBSD-[1-2].*|OpenBSD-*)
# Not available on all versions: check for include file.
ac_safe=`echo "dlfcn.h" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for dlfcn.h""... $ac_c" 1>&6
echo "configure:6064: checking for dlfcn.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 6069 "configure"
#include "confdefs.h"
#include <dlfcn.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6074: \"$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
|
| ︙ | ︙ | |||
5943 5944 5945 5946 5947 5948 5949 | SHLIB_CFLAGS="-fPIC" SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="" | | > | | | 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 |
SHLIB_CFLAGS="-fPIC"
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
echo $ac_n "checking for ELF""... $ac_c" 1>&6
echo "configure:6102: checking for ELF" >&5
cat > conftest.$ac_ext <<EOF
#line 6104 "configure"
#include "confdefs.h"
#ifdef __ELF__
yes
#endif
EOF
|
| ︙ | ︙ | |||
5979 5980 5981 5982 5983 5984 5985 |
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=""
| | > | > < < < | | | | > > > < > > > | > | 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 |
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'
fi
# FreeBSD doesn't handle 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="-export-dynamic"
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
if test "${TCL_THREADS}" = "1" ; then
EXTRA_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
;;
Rhapsody-*|Darwin-*)
SHLIB_CFLAGS="-fno-common"
SHLIB_LD="cc -dynamiclib \${LDFLAGS}"
TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${LIB_RUNTIME_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
PLAT_OBJS="tclMacOSXBundle.o"
DL_LIBS=""
LDFLAGS="-prebind"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
CFLAGS_OPTIMIZE="-Os"
LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
HACK=""
EXTRA_CFLAGS="-DMA${HACK}C_OSX_TCL -DHAVE_CFBUNDLE -DTCL_DEFAULT_ENCODING=\\\"utf-8\\\""
LIBS="$LIBS -framework CoreFoundation"
;;
NEXTSTEP-*)
SHLIB_CFLAGS=""
SHLIB_LD="cc -nostdlib -r"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadNext.o"
DL_LIBS=""
LDFLAGS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
OS/390-*)
CFLAGS_OPTIMIZE="" # Optimizer is buggy
cat >> confdefs.h <<\EOF
#define _OE_SOCKETS 1
EOF
# 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=""
LDFLAGS=""
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=""
LDFLAGS=""
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=""
LDFLAGS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
if test "$GCC" != "yes" ; then
EXTRA_CFLAGS="-DHAVE_TZSET -std1"
fi
# see pthread_intro(3) for pthread support on osf1, k.furukawa
if test "${TCL_THREADS}" = "1" ; then
EXTRA_CFLAGS="${EXTRA_CFLAGS} -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
EXTRA_CFLAGS="${EXTRA_CFLAGS} -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
|
| ︙ | ︙ | |||
6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 |
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# dlopen is in -lc on QNX
DL_LIBS=""
LDFLAGS=""
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="-Wl,-D,08000000"
| > | > > > | > | 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 |
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# dlopen is in -lc on QNX
DL_LIBS=""
LDFLAGS=""
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="-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="-melf -Wl,-Bexport"
else
SHLIB_CFLAGS="-Kpic -belf"
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"
LDFLAGS=""
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"
LDFLAGS=""
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'
|
| ︙ | ︙ | |||
6192 6193 6194 6195 6196 6197 6198 | cat >> confdefs.h <<\EOF #define _POSIX_PTHREAD_SEMANTICS 1 EOF SHLIB_CFLAGS="-KPIC" | < > | > > | > < | 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 |
cat >> confdefs.h <<\EOF
#define _POSIX_PTHREAD_SEMANTICS 1
EOF
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"
LDFLAGS=""
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.
cat >> confdefs.h <<\EOF
#define _REENTRANT 1
EOF
cat >> confdefs.h <<\EOF
#define _POSIX_PTHREAD_SEMANTICS 1
EOF
SHLIB_CFLAGS="-KPIC"
LDFLAGS=""
# 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
|
| ︙ | ︙ | |||
6255 6256 6257 6258 6259 6260 6261 |
# 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
| > | > > > | > | | | > | 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 |
# 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='-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="-Wl,-D,08000000"
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
if test "$GCC" != "yes" ; then
EXTRA_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.
hold_ldflags=$LDFLAGS
echo $ac_n "checking for ld accepts -Bexport flag""... $ac_c" 1>&6
echo "configure:6458: checking for ld accepts -Bexport flag" >&5
LDFLAGS="${LDFLAGS} -Wl,-Bexport"
cat > conftest.$ac_ext <<EOF
#line 6461 "configure"
#include "confdefs.h"
int main() {
int i;
; return 0; }
EOF
if { (eval echo configure:6468: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest${ac_exeext}; then
rm -rf conftest*
found=yes
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
found=no
fi
rm -f conftest*
LDFLAGS=$hold_ldflags
echo "$ac_t""$found" 1>&6
if test $found = yes; then
LDFLAGS="-Wl,-Bexport"
else
LDFLAGS=""
fi
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
esac
if test "$do64bit" = "yes" -a "$do64bit_ok" = "no" ; then
echo "configure: warning: "64bit support being disabled -- don\'t know magic for this platform"" 1>&2
fi
|
| ︙ | ︙ | |||
6340 6341 6342 6343 6344 6345 6346 |
#
# 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
echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6
| | | | | | | | | | | 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 |
#
# 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
echo $ac_n "checking sys/exec.h""... $ac_c" 1>&6
echo "configure:6515: checking sys/exec.h" >&5
cat > conftest.$ac_ext <<EOF
#line 6517 "configure"
#include "confdefs.h"
#include <sys/exec.h>
int main() {
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;
; return 0; }
EOF
if { (eval echo configure:6535: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_ok=usable
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_ok=unusable
fi
rm -f conftest*
echo "$ac_t""$tcl_ok" 1>&6
if test $tcl_ok = usable; then
cat >> confdefs.h <<\EOF
#define USE_SYS_EXEC_H 1
EOF
else
echo $ac_n "checking a.out.h""... $ac_c" 1>&6
echo "configure:6553: checking a.out.h" >&5
cat > conftest.$ac_ext <<EOF
#line 6555 "configure"
#include "confdefs.h"
#include <a.out.h>
int main() {
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;
; return 0; }
EOF
if { (eval echo configure:6573: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_ok=usable
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_ok=unusable
fi
rm -f conftest*
echo "$ac_t""$tcl_ok" 1>&6
if test $tcl_ok = usable; then
cat >> confdefs.h <<\EOF
#define USE_A_OUT_H 1
EOF
else
echo $ac_n "checking sys/exec_aout.h""... $ac_c" 1>&6
echo "configure:6591: checking sys/exec_aout.h" >&5
cat > conftest.$ac_ext <<EOF
#line 6593 "configure"
#include "confdefs.h"
#include <sys/exec_aout.h>
int main() {
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;
; return 0; }
EOF
if { (eval echo configure:6611: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
tcl_ok=usable
else
echo "configure: failed program was:" >&5
cat conftest.$ac_ext >&5
rm -rf conftest*
tcl_ok=unusable
|
| ︙ | ︙ | |||
6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 |
echo "on this system."
SHLIB_CFLAGS=""
SHLIB_LD=""
SHLIB_SUFFIX=""
DL_OBJS="tclLoadNone.o"
DL_LIBS=""
LDFLAGS=""
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.
| > | 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 |
echo "on this system."
SHLIB_CFLAGS=""
SHLIB_LD=""
SHLIB_SUFFIX=""
DL_OBJS="tclLoadNone.o"
DL_LIBS=""
LDFLAGS=""
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.
|
| ︙ | ︙ | |||
6526 6527 6528 6529 6530 6531 6532 |
SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
fi
if test "$UNSHARED_LIB_SUFFIX" = "" ; then
UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
fi
| | > > > > > > | > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | | | 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 |
SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
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 $@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_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)'
else
MAKE_LIB='${STLIB_LD} $@ ${OBJS} ; ${RANLIB} $@'
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(LIB_FILE))'
fi
fi
# Stub lib does not depend on shared/static configuration
if test "$RANLIB" = "" ; then
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS}'
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)'
else
MAKE_STUB_LIB='${STLIB_LD} $@ ${STUB_LIB_OBJS} ; ${RANLIB} $@'
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(STUB_LIB_FILE))'
fi
echo $ac_n "checking for build with symbols""... $ac_c" 1>&6
echo "configure:6764: 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
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "yes"; then
CFLAGS_DEFAULT='$(CFLAGS_DEBUG)'
LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)'
DBGX=g
echo "$ac_t""yes" 1>&6
else
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
DBGX=""
echo "$ac_t""no" 1>&6
fi
TCL_DBGX=${DBGX}
#--------------------------------------------------------------------
# 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.
#--------------------------------------------------------------------
for ac_hdr in sys/ioctl.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:6803: checking for $ac_hdr" >&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 6808 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6813: \"$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
|
| ︙ | ︙ | |||
6610 6611 6612 6613 6614 6615 6616 |
fi
done
for ac_hdr in sys/filio.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
| | | | | 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 |
fi
done
for ac_hdr in sys/filio.h
do
ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'`
echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6
echo "configure:6843: checking for $ac_hdr" >&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 6848 "configure"
#include "confdefs.h"
#include <$ac_hdr>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:6853: \"$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
|
| ︙ | ︙ | |||
6647 6648 6649 6650 6651 6652 6653 |
else
echo "$ac_t""no" 1>&6
fi
done
echo $ac_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O""... $ac_c" 1>&6
| | | 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 |
else
echo "$ac_t""no" 1>&6
fi
done
echo $ac_n "checking FIONBIO vs. O_NONBLOCK for nonblocking I/O""... $ac_c" 1>&6
echo "configure:6880: checking FIONBIO vs. O_NONBLOCK for nonblocking I/O" >&5
if test -f /usr/lib/NextStep/software_version; then
system=NEXTSTEP-`awk '/3/,/3/' /usr/lib/NextStep/software_version`
else
system=`uname -s`-`uname -r`
if test "$?" -ne 0 ; then
system=unknown
else
|
| ︙ | ︙ | |||
6706 6707 6708 6709 6710 6711 6712 |
#--------------------------------------------------------------------
# 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}
| | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > | | > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 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 |
#--------------------------------------------------------------------
# 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}"
echo $ac_n "checking how to package libraries""... $ac_c" 1>&6
echo "configure:6943: checking how to package libraries" >&5
# Check whether --enable-framework or --disable-framework was given.
if test "${enable_framework+set}" = set; then
enableval="$enable_framework"
tcl_ok=$enableval
else
tcl_ok=no
fi
if test "${enable_framework+set}" = set; then
enableval="$enable_framework"
tcl_ok=$enableval
else
tcl_ok=no
fi
if test "$tcl_ok" = "yes" ; then
echo "$ac_t""framework" 1>&6
FRAMEWORK_BUILD=1
if test "${SHARED_BUILD}" = "0" ; then
echo "configure: warning: "Frameworks can only be built if --enable-shared is yes"" 1>&2
FRAMEWORK_BUILD=0
fi
else
echo "$ac_t""standard shared library" 1>&6
FRAMEWORK_BUILD=0
fi
# 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}"
# 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 "$FRAMEWORK_BUILD" = "1" ; then
TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
TCL_LIB_SPEC="-framework Tcl"
TCL_LIB_FILE="Tcl"
elif 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}"
|
| ︙ | ︙ | |||
6848 6849 6850 6851 6852 6853 6854 | # 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 | | < < < | < < < < < < < | < < < < > < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
# 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="${libdir}/Resources/Scripts"
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}\""
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${libdir} ${TCL_STUB_LIB_FLAG}"
TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
TCL_STUB_LIB_PATH="${libdir}/${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}
|
| ︙ | ︙ | |||
7105 7106 7107 7108 7109 7110 7111 7112 | s%@sharedstatedir@%$sharedstatedir%g s%@localstatedir@%$localstatedir%g s%@libdir@%$libdir%g s%@includedir@%$includedir%g s%@oldincludedir@%$oldincludedir%g s%@infodir@%$infodir%g s%@mandir@%$mandir%g s%@CC@%$CC%g | > < > > > > > > > > > > > > > > > > > > > > > < | < < < < < < < < < < < < < < < < | 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 7268 7269 7270 7271 7272 7273 7274 7275 7276 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 | s%@sharedstatedir@%$sharedstatedir%g s%@localstatedir@%$localstatedir%g s%@libdir@%$libdir%g s%@includedir@%$includedir%g s%@oldincludedir@%$oldincludedir%g s%@infodir@%$infodir%g s%@mandir@%$mandir%g s%@MKLINKS_FLAGS@%$MKLINKS_FLAGS%g s%@CC@%$CC%g s%@CPP@%$CPP%g s%@TCL_THREADS@%$TCL_THREADS%g s%@LIBOBJS@%$LIBOBJS%g s%@TCL_LIBS@%$TCL_LIBS%g s%@MATH_LIBS@%$MATH_LIBS%g s%@AR@%$AR%g s%@RANLIB@%$RANLIB%g s%@DL_LIBS@%$DL_LIBS%g s%@DL_OBJS@%$DL_OBJS%g s%@PLAT_OBJS@%$PLAT_OBJS%g s%@CFLAGS_DEBUG@%$CFLAGS_DEBUG%g s%@CFLAGS_OPTIMIZE@%$CFLAGS_OPTIMIZE%g s%@CFLAGS_WARNING@%$CFLAGS_WARNING%g s%@EXTRA_CFLAGS@%$EXTRA_CFLAGS%g s%@LDFLAGS_DEBUG@%$LDFLAGS_DEBUG%g s%@LDFLAGS_OPTIMIZE@%$LDFLAGS_OPTIMIZE%g s%@CC_SEARCH_FLAGS@%$CC_SEARCH_FLAGS%g s%@LD_SEARCH_FLAGS@%$LD_SEARCH_FLAGS%g s%@STLIB_LD@%$STLIB_LD%g s%@SHLIB_LD@%$SHLIB_LD%g s%@TCL_SHLIB_LD_EXTRAS@%$TCL_SHLIB_LD_EXTRAS%g s%@SHLIB_LD_FLAGS@%$SHLIB_LD_FLAGS%g s%@SHLIB_LD_LIBS@%$SHLIB_LD_LIBS%g s%@SHLIB_CFLAGS@%$SHLIB_CFLAGS%g s%@SHLIB_SUFFIX@%$SHLIB_SUFFIX%g s%@MAKE_LIB@%$MAKE_LIB%g s%@MAKE_STUB_LIB@%$MAKE_STUB_LIB%g s%@INSTALL_LIB@%$INSTALL_LIB%g s%@INSTALL_STUB_LIB@%$INSTALL_STUB_LIB%g s%@CFLAGS_DEFAULT@%$CFLAGS_DEFAULT%g s%@LDFLAGS_DEFAULT@%$LDFLAGS_DEFAULT%g s%@TCL_VERSION@%$TCL_VERSION%g s%@TCL_MAJOR_VERSION@%$TCL_MAJOR_VERSION%g s%@TCL_MINOR_VERSION@%$TCL_MINOR_VERSION%g s%@TCL_PATCH_LEVEL@%$TCL_PATCH_LEVEL%g s%@TCL_LIB_FILE@%$TCL_LIB_FILE%g s%@TCL_LIB_FLAG@%$TCL_LIB_FLAG%g s%@TCL_LIB_SPEC@%$TCL_LIB_SPEC%g s%@TCL_STUB_LIB_FILE@%$TCL_STUB_LIB_FILE%g s%@TCL_STUB_LIB_FLAG@%$TCL_STUB_LIB_FLAG%g s%@TCL_STUB_LIB_SPEC@%$TCL_STUB_LIB_SPEC%g s%@TCL_STUB_LIB_PATH@%$TCL_STUB_LIB_PATH%g s%@TCL_INCLUDE_SPEC@%$TCL_INCLUDE_SPEC%g s%@TCL_BUILD_STUB_LIB_SPEC@%$TCL_BUILD_STUB_LIB_SPEC%g s%@TCL_BUILD_STUB_LIB_PATH@%$TCL_BUILD_STUB_LIB_PATH%g s%@TCL_SRC_DIR@%$TCL_SRC_DIR%g s%@TCL_DBGX@%$TCL_DBGX%g s%@CFG_TCL_SHARED_LIB_SUFFIX@%$CFG_TCL_SHARED_LIB_SUFFIX%g s%@CFG_TCL_UNSHARED_LIB_SUFFIX@%$CFG_TCL_UNSHARED_LIB_SUFFIX%g s%@CFG_TCL_EXPORT_FILE_SUFFIX@%$CFG_TCL_EXPORT_FILE_SUFFIX%g s%@TCL_SHARED_BUILD@%$TCL_SHARED_BUILD%g s%@LD_LIBRARY_PATH_VAR@%$LD_LIBRARY_PATH_VAR%g s%@TCL_BUILD_LIB_SPEC@%$TCL_BUILD_LIB_SPEC%g s%@TCL_NEEDS_EXP_FILE@%$TCL_NEEDS_EXP_FILE%g s%@TCL_BUILD_EXP_FILE@%$TCL_BUILD_EXP_FILE%g s%@TCL_EXP_FILE@%$TCL_EXP_FILE%g s%@TCL_LIB_VERSIONS_OK@%$TCL_LIB_VERSIONS_OK%g s%@TCL_SHARED_LIB_SUFFIX@%$TCL_SHARED_LIB_SUFFIX%g s%@TCL_UNSHARED_LIB_SUFFIX@%$TCL_UNSHARED_LIB_SUFFIX%g s%@TCL_HAS_LONGLONG@%$TCL_HAS_LONGLONG%g s%@BUILD_DLTEST@%$BUILD_DLTEST%g s%@TCL_PACKAGE_PATH@%$TCL_PACKAGE_PATH%g CEOF EOF cat >> $CONFIG_STATUS <<\EOF |
| ︙ | ︙ |
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 |
#! /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.72.8.6 2002/08/20 20:25:30 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="b3"
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
# libdir must be a fully qualified path and (not ${exec_prefix}/lib)
eval libdir="$libdir"
TCL_SRC_DIR=`cd $srcdir/..; pwd`
#------------------------------------------------------------------------
# Compress and/or soft link the manpages?
#------------------------------------------------------------------------
SC_CONFIG_MANPAGES
#------------------------------------------------------------------------
# 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
AC_HAVE_HEADERS(unistd.h limits.h)
#------------------------------------------------------------------------
# Threads support
#------------------------------------------------------------------------
SC_ENABLE_THREADS
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 264 265 266 267 268 269 270 | # they don't exist. #-------------------------------------------------------------------- AC_TYPE_MODE_T AC_TYPE_PID_T AC_TYPE_SIZE_T AC_TYPE_UID_T #-------------------------------------------------------------------- # 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 # is compatible with the substitute version of opendir that's # provided. This version only works with V7-style directories. #-------------------------------------------------------------------- | > > > > > > > > > > > > > > > > | 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 | # they don't exist. #-------------------------------------------------------------------- AC_TYPE_MODE_T AC_TYPE_PID_T AC_TYPE_SIZE_T AC_TYPE_UID_T AC_MSG_CHECKING([for socklen_t]) AC_CACHE_VAL(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) AC_MSG_RESULT($ac_cv_type_socklen_t) 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 # is compatible with the substitute version of opendir that's # provided. This version only works with V7-style directories. #-------------------------------------------------------------------- |
| ︙ | ︙ | |||
362 363 364 365 366 367 368 369 370 371 372 373 374 375 | #-------------------------------------------------------------------- SC_TCL_LINK_LIBS # Add the threads support libraries LIBS="$LIBS$THREADS_LIBS" #-------------------------------------------------------------------- # 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. #-------------------------------------------------------------------- | > > | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 | #-------------------------------------------------------------------- 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. #-------------------------------------------------------------------- |
| ︙ | ︙ | |||
391 392 393 394 395 396 397 |
#--------------------------------------------------------------------
# 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}
| < < < < < < < | < < < < < < < < < < < | < < < < < < < < | | 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 |
#--------------------------------------------------------------------
# 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}"
SC_ENABLE_FRAMEWORK
# 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}"
# 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 "$FRAMEWORK_BUILD" = "1" ; then
TCL_BUILD_LIB_SPEC="-F`pwd` -framework Tcl"
TCL_LIB_SPEC="-framework Tcl"
TCL_LIB_FILE="Tcl"
elif 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}"
|
| ︙ | ︙ | |||
474 475 476 477 478 479 480 | # 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 | | < < < | < < < < < < < | < < < < > | 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 |
# 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="${libdir}/Resources/Scripts"
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}\""
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${libdir} ${TCL_STUB_LIB_FLAG}"
TCL_BUILD_STUB_LIB_PATH="`pwd`/${TCL_STUB_LIB_FILE}"
TCL_STUB_LIB_PATH="${libdir}/${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
#------------------------------------------------------------------------
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 | AC_SUBST(TCL_STUB_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_PATH) AC_SUBST(TCL_INCLUDE_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_PATH) AC_SUBST(TCL_SRC_DIR) | < < < < | < < < < < < < < < < < < < < < < < < < < | 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 | AC_SUBST(TCL_STUB_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_PATH) AC_SUBST(TCL_INCLUDE_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) AC_SUBST(TCL_BUILD_STUB_LIB_PATH) AC_SUBST(TCL_SRC_DIR) AC_SUBST(TCL_DBGX) AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX) AC_SUBST(TCL_SHARED_BUILD) AC_SUBST(LD_LIBRARY_PATH_VAR) AC_SUBST(TCL_BUILD_LIB_SPEC) AC_SUBST(TCL_NEEDS_EXP_FILE) AC_SUBST(TCL_BUILD_EXP_FILE) AC_SUBST(TCL_EXP_FILE) AC_SUBST(TCL_LIB_VERSIONS_OK) AC_SUBST(TCL_SHARED_LIB_SUFFIX) AC_SUBST(TCL_UNSHARED_LIB_SUFFIX) AC_SUBST(TCL_HAS_LONGLONG) AC_SUBST(BUILD_DLTEST) AC_SUBST(TCL_PACKAGE_PATH) AC_OUTPUT(Makefile dltest/Makefile tclConfig.sh) |
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 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
# 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.6.18.3 2002/08/20 20:25:31 das Exp $
TCL_DBGX = @TCL_DBGX@
CC = @CC@
LIBS = @TCL_BUILD_STUB_LIB_SPEC@ @DL_LIBS@ @LIBS@ @MATH_LIBS@
AC_FLAGS = @EXTRA_CFLAGS@
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@
CFLAGS_DEBUG = @CFLAGS_DEBUG@
CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@
CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@
CC_SWITCHES = $(CFLAGS) -I${SRC_DIR}/../../generic -DTCL_MEM_DEBUG \
${SHLIB_CFLAGS} -DUSE_TCL_STUBS ${AC_FLAGS}
all: pkga${SHLIB_SUFFIX} pkgb${SHLIB_SUFFIX} pkgc${SHLIB_SUFFIX} pkgd${SHLIB_SUFFIX} pkge${SHLIB_SUFFIX}
@touch ../dltest.marker
pkga${SHLIB_SUFFIX}: $(SRC_DIR)/pkga.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkga.c
${SHLIB_LD} -o pkga${SHLIB_SUFFIX} pkga.o ${SHLIB_LD_LIBS}
pkgb${SHLIB_SUFFIX}: $(SRC_DIR)/pkgb.c
$(CC) -c $(CC_SWITCHES) $(SRC_DIR)/pkgb.c
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 |
${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 |
${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 *${SHLIB_SUFFIX} config.cache config.log config.status
rm -f lib.exp ../dltest.marker
distclean: clean
rm -f Makefile
|
Changes to unix/mkLinks.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 | # Because of the length of command and procedure names, this mechanism # only works on machines that support file names longer than 14 characters. # This script checks to see if long file names are supported, and it # doesn't make any links if they are not. # # The script takes one argument, which is the name of the directory # where the manual entries have been installed. if test $# != 1; then | > > > > > > > > > > > > > > > > | > > > > > > > > > | | | | > > | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | > > | | > > | | > > | | | | | | > > | | | | | | | | | | > > | | > | | > > > | | | | | | > > | | | | | | | | > > | | | | > > | | | | | | | | > > | | > > | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | > > | | | | > > | | > > | | | | > > | | | | | | > > | | | | | | > > | | | | | | | | > > | | | | | | | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | > > | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | > | | > > > | | | | > > | | | | | | > > | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | > > | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | > > | | | | | | | | > > | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | > > | | | | > | | > > > | | | | > > | | | | | | > > | | > > | | | | > > | | > | | > > > | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | > | | > > > | | | | | | | | | | | | | | | | | | > > | | > > | | | | | | > > | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | > > | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | > > | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | > > | | | | | | > > | | > > | | > > | | > > | | | | | | | | | | | | | | | | > > | | | | | | > > | | | | | | | | > > | | > > | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | > > | | | | > > | | > | | > > > | | | | | | | | | | | | > > | | | | | | > > | | > > | | > > | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | > > > > > > > > | > | > > > | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | > > | | | | | | > > | | | | | | | | | | | | > > | | > > | | | | | | | | | | | | | | | | | | | | | | > > | | | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | | > > | < | > > > > > > > > > > > | | > | | > | | | > > > > > > > | > > > > > > > > > > | | > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# Because of the length of command and procedure names, this mechanism
# only works on machines that support file names longer than 14 characters.
# This script checks to see if long file names are supported, and it
# doesn't make any links if they are not.
#
# The script takes one argument, which is the name of the directory
# where the manual entries have been installed.
ZIP=true
while true; do
case $1 in
-s | --symlinks )
S=-s
;;
-z | --compress )
ZIP=$2
shift
;;
*) break
;;
esac
shift
done
if test $# != 1; then
echo "Usage: mkLinks <options> dir"
exit 1
fi
if test "x$ZIP" != "xtrue"; then
touch TeST
$ZIP TeST
Z=`ls TeST* | sed 's/^[^.]*//'`
rm -f TeST*
fi
cd $1
echo foo > xyzzyTestingAVeryLongFileName.foo
x=`echo xyzzyTe*`
echo foo > xyzzyTestingaverylongfilename.foo
y=`echo xyzzyTestingav*`
rm xyzzyTe*
if test "$x" != "xyzzyTestingAVeryLongFileName.foo"; then
exit
fi
if test "$y" != "xyzzyTestingaverylongfilename.foo"; then
CASEINSENSITIVEFS=1
fi
if test -r Access.3; then
rm -f Access.3.*
$ZIP Access.3
rm -f Tcl_Access.3 Tcl_Access.3.*
rm -f Tcl_Stat.3 Tcl_Stat.3.*
ln $S Access.3$Z Tcl_Access.3$Z
ln $S Access.3$Z Tcl_Stat.3$Z
fi
if test -r AddErrInfo.3; then
rm -f AddErrInfo.3.*
$ZIP AddErrInfo.3
rm -f Tcl_AddObjErrorInfo.3 Tcl_AddObjErrorInfo.3.*
rm -f Tcl_AddErrorInfo.3 Tcl_AddErrorInfo.3.*
rm -f Tcl_SetObjErrorCode.3 Tcl_SetObjErrorCode.3.*
rm -f Tcl_SetErrorCode.3 Tcl_SetErrorCode.3.*
rm -f Tcl_SetErrorCodeVA.3 Tcl_SetErrorCodeVA.3.*
rm -f Tcl_PosixError.3 Tcl_PosixError.3.*
rm -f Tcl_LogCommandInfo.3 Tcl_LogCommandInfo.3.*
ln $S AddErrInfo.3$Z Tcl_AddObjErrorInfo.3$Z
ln $S AddErrInfo.3$Z Tcl_AddErrorInfo.3$Z
ln $S AddErrInfo.3$Z Tcl_SetObjErrorCode.3$Z
ln $S AddErrInfo.3$Z Tcl_SetErrorCode.3$Z
ln $S AddErrInfo.3$Z Tcl_SetErrorCodeVA.3$Z
ln $S AddErrInfo.3$Z Tcl_PosixError.3$Z
ln $S AddErrInfo.3$Z Tcl_LogCommandInfo.3$Z
fi
if test -r Alloc.3; then
rm -f Alloc.3.*
$ZIP Alloc.3
rm -f Tcl_Alloc.3 Tcl_Alloc.3.*
rm -f Tcl_Free.3 Tcl_Free.3.*
rm -f Tcl_Realloc.3 Tcl_Realloc.3.*
rm -f Tcl_AttemptAlloc.3 Tcl_AttemptAlloc.3.*
rm -f Tcl_AttemptRealloc.3 Tcl_AttemptRealloc.3.*
rm -f ckalloc.3 ckalloc.3.*
rm -f ckfree.3 ckfree.3.*
rm -f ckrealloc.3 ckrealloc.3.*
rm -f attemptckalloc.3 attemptckalloc.3.*
rm -f attemptckrealloc.3 attemptckrealloc.3.*
ln $S Alloc.3$Z Tcl_Alloc.3$Z
ln $S Alloc.3$Z Tcl_Free.3$Z
ln $S Alloc.3$Z Tcl_Realloc.3$Z
ln $S Alloc.3$Z Tcl_AttemptAlloc.3$Z
ln $S Alloc.3$Z Tcl_AttemptRealloc.3$Z
ln $S Alloc.3$Z ckalloc.3$Z
ln $S Alloc.3$Z ckfree.3$Z
ln $S Alloc.3$Z ckrealloc.3$Z
ln $S Alloc.3$Z attemptckalloc.3$Z
ln $S Alloc.3$Z attemptckrealloc.3$Z
fi
if test -r AllowExc.3; then
rm -f AllowExc.3.*
$ZIP AllowExc.3
rm -f Tcl_AllowExceptions.3 Tcl_AllowExceptions.3.*
ln $S AllowExc.3$Z Tcl_AllowExceptions.3$Z
fi
if test -r AppInit.3; then
rm -f AppInit.3.*
$ZIP AppInit.3
rm -f Tcl_AppInit.3 Tcl_AppInit.3.*
ln $S AppInit.3$Z Tcl_AppInit.3$Z
fi
if test -r AssocData.3; then
rm -f AssocData.3.*
$ZIP AssocData.3
rm -f Tcl_GetAssocData.3 Tcl_GetAssocData.3.*
rm -f Tcl_SetAssocData.3 Tcl_SetAssocData.3.*
rm -f Tcl_DeleteAssocData.3 Tcl_DeleteAssocData.3.*
ln $S AssocData.3$Z Tcl_GetAssocData.3$Z
ln $S AssocData.3$Z Tcl_SetAssocData.3$Z
ln $S AssocData.3$Z Tcl_DeleteAssocData.3$Z
fi
if test -r Async.3; then
rm -f Async.3.*
$ZIP Async.3
rm -f Tcl_AsyncCreate.3 Tcl_AsyncCreate.3.*
rm -f Tcl_AsyncMark.3 Tcl_AsyncMark.3.*
rm -f Tcl_AsyncInvoke.3 Tcl_AsyncInvoke.3.*
rm -f Tcl_AsyncDelete.3 Tcl_AsyncDelete.3.*
rm -f Tcl_AsyncReady.3 Tcl_AsyncReady.3.*
ln $S Async.3$Z Tcl_AsyncCreate.3$Z
ln $S Async.3$Z Tcl_AsyncMark.3$Z
ln $S Async.3$Z Tcl_AsyncInvoke.3$Z
ln $S Async.3$Z Tcl_AsyncDelete.3$Z
ln $S Async.3$Z Tcl_AsyncReady.3$Z
fi
if test -r BackgdErr.3; then
rm -f BackgdErr.3.*
$ZIP BackgdErr.3
rm -f Tcl_BackgroundError.3 Tcl_BackgroundError.3.*
ln $S BackgdErr.3$Z Tcl_BackgroundError.3$Z
fi
if test -r Backslash.3; then
rm -f Backslash.3.*
$ZIP Backslash.3
rm -f Tcl_Backslash.3 Tcl_Backslash.3.*
ln $S Backslash.3$Z Tcl_Backslash.3$Z
fi
if test -r BoolObj.3; then
rm -f BoolObj.3.*
$ZIP BoolObj.3
rm -f Tcl_NewBooleanObj.3 Tcl_NewBooleanObj.3.*
rm -f Tcl_SetBooleanObj.3 Tcl_SetBooleanObj.3.*
rm -f Tcl_GetBooleanFromObj.3 Tcl_GetBooleanFromObj.3.*
ln $S BoolObj.3$Z Tcl_NewBooleanObj.3$Z
ln $S BoolObj.3$Z Tcl_SetBooleanObj.3$Z
ln $S BoolObj.3$Z Tcl_GetBooleanFromObj.3$Z
fi
if test -r ByteArrObj.3; then
rm -f ByteArrObj.3.*
$ZIP ByteArrObj.3
rm -f Tcl_NewByteArrayObj.3 Tcl_NewByteArrayObj.3.*
rm -f Tcl_SetByteArrayObj.3 Tcl_SetByteArrayObj.3.*
rm -f Tcl_GetByteArrayFromObj.3 Tcl_GetByteArrayFromObj.3.*
rm -f Tcl_SetByteArrayLength.3 Tcl_SetByteArrayLength.3.*
ln $S ByteArrObj.3$Z Tcl_NewByteArrayObj.3$Z
ln $S ByteArrObj.3$Z Tcl_SetByteArrayObj.3$Z
ln $S ByteArrObj.3$Z Tcl_GetByteArrayFromObj.3$Z
ln $S ByteArrObj.3$Z Tcl_SetByteArrayLength.3$Z
fi
if test -r CallDel.3; then
rm -f CallDel.3.*
$ZIP CallDel.3
rm -f Tcl_CallWhenDeleted.3 Tcl_CallWhenDeleted.3.*
rm -f Tcl_DontCallWhenDeleted.3 Tcl_DontCallWhenDeleted.3.*
ln $S CallDel.3$Z Tcl_CallWhenDeleted.3$Z
ln $S CallDel.3$Z Tcl_DontCallWhenDeleted.3$Z
fi
if test -r ChnlStack.3; then
rm -f ChnlStack.3.*
$ZIP ChnlStack.3
rm -f Tcl_StackChannel.3 Tcl_StackChannel.3.*
rm -f Tcl_UnstackChannel.3 Tcl_UnstackChannel.3.*
rm -f Tcl_GetStackedChannel.3 Tcl_GetStackedChannel.3.*
rm -f Tcl_GetTopChannel.3 Tcl_GetTopChannel.3.*
ln $S ChnlStack.3$Z Tcl_StackChannel.3$Z
ln $S ChnlStack.3$Z Tcl_UnstackChannel.3$Z
ln $S ChnlStack.3$Z Tcl_GetStackedChannel.3$Z
ln $S ChnlStack.3$Z Tcl_GetTopChannel.3$Z
fi
if test -r CmdCmplt.3; then
rm -f CmdCmplt.3.*
$ZIP CmdCmplt.3
rm -f Tcl_CommandComplete.3 Tcl_CommandComplete.3.*
ln $S CmdCmplt.3$Z Tcl_CommandComplete.3$Z
fi
if test -r Concat.3; then
rm -f Concat.3.*
$ZIP Concat.3
rm -f Tcl_Concat.3 Tcl_Concat.3.*
ln $S Concat.3$Z Tcl_Concat.3$Z
fi
if test -r CrtChannel.3; then
rm -f CrtChannel.3.*
$ZIP CrtChannel.3
rm -f Tcl_CreateChannel.3 Tcl_CreateChannel.3.*
rm -f Tcl_GetChannelInstanceData.3 Tcl_GetChannelInstanceData.3.*
rm -f Tcl_GetChannelType.3 Tcl_GetChannelType.3.*
rm -f Tcl_GetChannelName.3 Tcl_GetChannelName.3.*
rm -f Tcl_GetChannelHandle.3 Tcl_GetChannelHandle.3.*
rm -f Tcl_GetChannelMode.3 Tcl_GetChannelMode.3.*
rm -f Tcl_GetChannelBufferSize.3 Tcl_GetChannelBufferSize.3.*
rm -f Tcl_SetChannelBufferSize.3 Tcl_SetChannelBufferSize.3.*
rm -f Tcl_NotifyChannel.3 Tcl_NotifyChannel.3.*
rm -f Tcl_BadChannelOption.3 Tcl_BadChannelOption.3.*
rm -f Tcl_ChannelName.3 Tcl_ChannelName.3.*
rm -f Tcl_ChannelVersion.3 Tcl_ChannelVersion.3.*
rm -f Tcl_ChannelBlockModeProc.3 Tcl_ChannelBlockModeProc.3.*
rm -f Tcl_ChannelCloseProc.3 Tcl_ChannelCloseProc.3.*
rm -f Tcl_ChannelClose2Proc.3 Tcl_ChannelClose2Proc.3.*
rm -f Tcl_ChannelInputProc.3 Tcl_ChannelInputProc.3.*
rm -f Tcl_ChannelOutputProc.3 Tcl_ChannelOutputProc.3.*
rm -f Tcl_ChannelSeekProc.3 Tcl_ChannelSeekProc.3.*
rm -f Tcl_ChannelWideSeekProc.3 Tcl_ChannelWideSeekProc.3.*
rm -f Tcl_ChannelSetOptionProc.3 Tcl_ChannelSetOptionProc.3.*
rm -f Tcl_ChannelGetOptionProc.3 Tcl_ChannelGetOptionProc.3.*
rm -f Tcl_ChannelWatchProc.3 Tcl_ChannelWatchProc.3.*
rm -f Tcl_ChannelGetHandleProc.3 Tcl_ChannelGetHandleProc.3.*
rm -f Tcl_ChannelFlushProc.3 Tcl_ChannelFlushProc.3.*
rm -f Tcl_ChannelHandlerProc.3 Tcl_ChannelHandlerProc.3.*
rm -f Tcl_IsChannelShared.3 Tcl_IsChannelShared.3.*
rm -f Tcl_IsChannelRegistered.3 Tcl_IsChannelRegistered.3.*
rm -f Tcl_CutChannel.3 Tcl_CutChannel.3.*
rm -f Tcl_SpliceChannel.3 Tcl_SpliceChannel.3.*
rm -f Tcl_IsChannelExisting.3 Tcl_IsChannelExisting.3.*
rm -f Tcl_ClearChannelHandlers.3 Tcl_ClearChannelHandlers.3.*
rm -f Tcl_GetChannelThread.3 Tcl_GetChannelThread.3.*
rm -f Tcl_ChannelBuffered.3 Tcl_ChannelBuffered.3.*
ln $S CrtChannel.3$Z Tcl_CreateChannel.3$Z
ln $S CrtChannel.3$Z Tcl_GetChannelInstanceData.3$Z
ln $S CrtChannel.3$Z Tcl_GetChannelType.3$Z
ln $S CrtChannel.3$Z Tcl_GetChannelName.3$Z
ln $S CrtChannel.3$Z Tcl_GetChannelHandle.3$Z
ln $S CrtChannel.3$Z Tcl_GetChannelMode.3$Z
ln $S CrtChannel.3$Z Tcl_GetChannelBufferSize.3$Z
ln $S CrtChannel.3$Z Tcl_SetChannelBufferSize.3$Z
ln $S CrtChannel.3$Z Tcl_NotifyChannel.3$Z
ln $S CrtChannel.3$Z Tcl_BadChannelOption.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelName.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelVersion.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelBlockModeProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelCloseProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelClose2Proc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelInputProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelOutputProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelSeekProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelWideSeekProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelSetOptionProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelGetOptionProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelWatchProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelGetHandleProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelFlushProc.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelHandlerProc.3$Z
ln $S CrtChannel.3$Z Tcl_IsChannelShared.3$Z
ln $S CrtChannel.3$Z Tcl_IsChannelRegistered.3$Z
ln $S CrtChannel.3$Z Tcl_CutChannel.3$Z
ln $S CrtChannel.3$Z Tcl_SpliceChannel.3$Z
ln $S CrtChannel.3$Z Tcl_IsChannelExisting.3$Z
ln $S CrtChannel.3$Z Tcl_ClearChannelHandlers.3$Z
ln $S CrtChannel.3$Z Tcl_GetChannelThread.3$Z
ln $S CrtChannel.3$Z Tcl_ChannelBuffered.3$Z
fi
if test -r CrtChnlHdlr.3; then
rm -f CrtChnlHdlr.3.*
$ZIP CrtChnlHdlr.3
rm -f Tcl_CreateChannelHandler.3 Tcl_CreateChannelHandler.3.*
rm -f Tcl_DeleteChannelHandler.3 Tcl_DeleteChannelHandler.3.*
ln $S CrtChnlHdlr.3$Z Tcl_CreateChannelHandler.3$Z
ln $S CrtChnlHdlr.3$Z Tcl_DeleteChannelHandler.3$Z
fi
if test -r CrtCloseHdlr.3; then
rm -f CrtCloseHdlr.3.*
$ZIP CrtCloseHdlr.3
rm -f Tcl_CreateCloseHandler.3 Tcl_CreateCloseHandler.3.*
rm -f Tcl_DeleteCloseHandler.3 Tcl_DeleteCloseHandler.3.*
ln $S CrtCloseHdlr.3$Z Tcl_CreateCloseHandler.3$Z
ln $S CrtCloseHdlr.3$Z Tcl_DeleteCloseHandler.3$Z
fi
if test -r CrtCommand.3; then
rm -f CrtCommand.3.*
$ZIP CrtCommand.3
rm -f Tcl_CreateCommand.3 Tcl_CreateCommand.3.*
ln $S CrtCommand.3$Z Tcl_CreateCommand.3$Z
fi
if test -r CrtFileHdlr.3; then
rm -f CrtFileHdlr.3.*
$ZIP CrtFileHdlr.3
rm -f Tcl_CreateFileHandler.3 Tcl_CreateFileHandler.3.*
rm -f Tcl_DeleteFileHandler.3 Tcl_DeleteFileHandler.3.*
ln $S CrtFileHdlr.3$Z Tcl_CreateFileHandler.3$Z
ln $S CrtFileHdlr.3$Z Tcl_DeleteFileHandler.3$Z
fi
if test -r CrtInterp.3; then
rm -f CrtInterp.3.*
$ZIP CrtInterp.3
rm -f Tcl_CreateInterp.3 Tcl_CreateInterp.3.*
rm -f Tcl_DeleteInterp.3 Tcl_DeleteInterp.3.*
rm -f Tcl_InterpDeleted.3 Tcl_InterpDeleted.3.*
ln $S CrtInterp.3$Z Tcl_CreateInterp.3$Z
ln $S CrtInterp.3$Z Tcl_DeleteInterp.3$Z
ln $S CrtInterp.3$Z Tcl_InterpDeleted.3$Z
fi
if test -r CrtMathFnc.3; then
rm -f CrtMathFnc.3.*
$ZIP CrtMathFnc.3
rm -f Tcl_CreateMathFunc.3 Tcl_CreateMathFunc.3.*
rm -f Tcl_GetMathFuncInfo.3 Tcl_GetMathFuncInfo.3.*
rm -f Tcl_ListMathFuncs.3 Tcl_ListMathFuncs.3.*
ln $S CrtMathFnc.3$Z Tcl_CreateMathFunc.3$Z
ln $S CrtMathFnc.3$Z Tcl_GetMathFuncInfo.3$Z
ln $S CrtMathFnc.3$Z Tcl_ListMathFuncs.3$Z
fi
if test -r CrtObjCmd.3; then
rm -f CrtObjCmd.3.*
$ZIP CrtObjCmd.3
rm -f Tcl_CreateObjCommand.3 Tcl_CreateObjCommand.3.*
rm -f Tcl_DeleteCommand.3 Tcl_DeleteCommand.3.*
rm -f Tcl_DeleteCommandFromToken.3 Tcl_DeleteCommandFromToken.3.*
rm -f Tcl_GetCommandInfo.3 Tcl_GetCommandInfo.3.*
rm -f Tcl_GetCommandInfoFromToken.3 Tcl_GetCommandInfoFromToken.3.*
rm -f Tcl_SetCommandInfo.3 Tcl_SetCommandInfo.3.*
rm -f Tcl_SetCommandInfoFromToken.3 Tcl_SetCommandInfoFromToken.3.*
rm -f Tcl_GetCommandName.3 Tcl_GetCommandName.3.*
rm -f Tcl_GetCommandFullName.3 Tcl_GetCommandFullName.3.*
rm -f Tcl_GetCommandFromObj.3 Tcl_GetCommandFromObj.3.*
ln $S CrtObjCmd.3$Z Tcl_CreateObjCommand.3$Z
ln $S CrtObjCmd.3$Z Tcl_DeleteCommand.3$Z
ln $S CrtObjCmd.3$Z Tcl_DeleteCommandFromToken.3$Z
ln $S CrtObjCmd.3$Z Tcl_GetCommandInfo.3$Z
ln $S CrtObjCmd.3$Z Tcl_GetCommandInfoFromToken.3$Z
ln $S CrtObjCmd.3$Z Tcl_SetCommandInfo.3$Z
ln $S CrtObjCmd.3$Z Tcl_SetCommandInfoFromToken.3$Z
ln $S CrtObjCmd.3$Z Tcl_GetCommandName.3$Z
ln $S CrtObjCmd.3$Z Tcl_GetCommandFullName.3$Z
ln $S CrtObjCmd.3$Z Tcl_GetCommandFromObj.3$Z
fi
if test -r CrtSlave.3; then
rm -f CrtSlave.3.*
$ZIP CrtSlave.3
rm -f Tcl_IsSafe.3 Tcl_IsSafe.3.*
rm -f Tcl_MakeSafe.3 Tcl_MakeSafe.3.*
rm -f Tcl_CreateSlave.3 Tcl_CreateSlave.3.*
rm -f Tcl_GetSlave.3 Tcl_GetSlave.3.*
rm -f Tcl_GetMaster.3 Tcl_GetMaster.3.*
rm -f Tcl_GetInterpPath.3 Tcl_GetInterpPath.3.*
rm -f Tcl_CreateAlias.3 Tcl_CreateAlias.3.*
rm -f Tcl_CreateAliasObj.3 Tcl_CreateAliasObj.3.*
rm -f Tcl_GetAlias.3 Tcl_GetAlias.3.*
rm -f Tcl_GetAliasObj.3 Tcl_GetAliasObj.3.*
rm -f Tcl_ExposeCommand.3 Tcl_ExposeCommand.3.*
rm -f Tcl_HideCommand.3 Tcl_HideCommand.3.*
ln $S CrtSlave.3$Z Tcl_IsSafe.3$Z
ln $S CrtSlave.3$Z Tcl_MakeSafe.3$Z
ln $S CrtSlave.3$Z Tcl_CreateSlave.3$Z
ln $S CrtSlave.3$Z Tcl_GetSlave.3$Z
ln $S CrtSlave.3$Z Tcl_GetMaster.3$Z
ln $S CrtSlave.3$Z Tcl_GetInterpPath.3$Z
ln $S CrtSlave.3$Z Tcl_CreateAlias.3$Z
ln $S CrtSlave.3$Z Tcl_CreateAliasObj.3$Z
ln $S CrtSlave.3$Z Tcl_GetAlias.3$Z
ln $S CrtSlave.3$Z Tcl_GetAliasObj.3$Z
ln $S CrtSlave.3$Z Tcl_ExposeCommand.3$Z
ln $S CrtSlave.3$Z Tcl_HideCommand.3$Z
fi
if test -r CrtTimerHdlr.3; then
rm -f CrtTimerHdlr.3.*
$ZIP CrtTimerHdlr.3
rm -f Tcl_CreateTimerHandler.3 Tcl_CreateTimerHandler.3.*
rm -f Tcl_DeleteTimerHandler.3 Tcl_DeleteTimerHandler.3.*
ln $S CrtTimerHdlr.3$Z Tcl_CreateTimerHandler.3$Z
ln $S CrtTimerHdlr.3$Z Tcl_DeleteTimerHandler.3$Z
fi
if test -r CrtTrace.3; then
rm -f CrtTrace.3.*
$ZIP CrtTrace.3
rm -f Tcl_CreateTrace.3 Tcl_CreateTrace.3.*
rm -f Tcl_CreateObjTrace.3 Tcl_CreateObjTrace.3.*
rm -f Tcl_DeleteTrace.3 Tcl_DeleteTrace.3.*
ln $S CrtTrace.3$Z Tcl_CreateTrace.3$Z
ln $S CrtTrace.3$Z Tcl_CreateObjTrace.3$Z
ln $S CrtTrace.3$Z Tcl_DeleteTrace.3$Z
fi
if test -r DString.3; then
rm -f DString.3.*
$ZIP DString.3
rm -f Tcl_DStringInit.3 Tcl_DStringInit.3.*
rm -f Tcl_DStringAppend.3 Tcl_DStringAppend.3.*
rm -f Tcl_DStringAppendElement.3 Tcl_DStringAppendElement.3.*
rm -f Tcl_DStringStartSublist.3 Tcl_DStringStartSublist.3.*
rm -f Tcl_DStringEndSublist.3 Tcl_DStringEndSublist.3.*
rm -f Tcl_DStringLength.3 Tcl_DStringLength.3.*
rm -f Tcl_DStringValue.3 Tcl_DStringValue.3.*
rm -f Tcl_DStringSetLength.3 Tcl_DStringSetLength.3.*
rm -f Tcl_DStringTrunc.3 Tcl_DStringTrunc.3.*
rm -f Tcl_DStringFree.3 Tcl_DStringFree.3.*
rm -f Tcl_DStringResult.3 Tcl_DStringResult.3.*
rm -f Tcl_DStringGetResult.3 Tcl_DStringGetResult.3.*
ln $S DString.3$Z Tcl_DStringInit.3$Z
ln $S DString.3$Z Tcl_DStringAppend.3$Z
ln $S DString.3$Z Tcl_DStringAppendElement.3$Z
ln $S DString.3$Z Tcl_DStringStartSublist.3$Z
ln $S DString.3$Z Tcl_DStringEndSublist.3$Z
ln $S DString.3$Z Tcl_DStringLength.3$Z
ln $S DString.3$Z Tcl_DStringValue.3$Z
ln $S DString.3$Z Tcl_DStringSetLength.3$Z
ln $S DString.3$Z Tcl_DStringTrunc.3$Z
ln $S DString.3$Z Tcl_DStringFree.3$Z
ln $S DString.3$Z Tcl_DStringResult.3$Z
ln $S DString.3$Z Tcl_DStringGetResult.3$Z
fi
if test -r DetachPids.3; then
rm -f DetachPids.3.*
$ZIP DetachPids.3
rm -f Tcl_DetachPids.3 Tcl_DetachPids.3.*
rm -f Tcl_ReapDetachedProcs.3 Tcl_ReapDetachedProcs.3.*
rm -f Tcl_WaitPid.3 Tcl_WaitPid.3.*
ln $S DetachPids.3$Z Tcl_DetachPids.3$Z
ln $S DetachPids.3$Z Tcl_ReapDetachedProcs.3$Z
ln $S DetachPids.3$Z Tcl_WaitPid.3$Z
fi
if test -r DoOneEvent.3; then
rm -f DoOneEvent.3.*
$ZIP DoOneEvent.3
rm -f Tcl_DoOneEvent.3 Tcl_DoOneEvent.3.*
ln $S DoOneEvent.3$Z Tcl_DoOneEvent.3$Z
fi
if test -r DoWhenIdle.3; then
rm -f DoWhenIdle.3.*
$ZIP DoWhenIdle.3
rm -f Tcl_DoWhenIdle.3 Tcl_DoWhenIdle.3.*
rm -f Tcl_CancelIdleCall.3 Tcl_CancelIdleCall.3.*
ln $S DoWhenIdle.3$Z Tcl_DoWhenIdle.3$Z
ln $S DoWhenIdle.3$Z Tcl_CancelIdleCall.3$Z
fi
if test -r DoubleObj.3; then
rm -f DoubleObj.3.*
$ZIP DoubleObj.3
rm -f Tcl_NewDoubleObj.3 Tcl_NewDoubleObj.3.*
rm -f Tcl_SetDoubleObj.3 Tcl_SetDoubleObj.3.*
rm -f Tcl_GetDoubleFromObj.3 Tcl_GetDoubleFromObj.3.*
ln $S DoubleObj.3$Z Tcl_NewDoubleObj.3$Z
ln $S DoubleObj.3$Z Tcl_SetDoubleObj.3$Z
ln $S DoubleObj.3$Z Tcl_GetDoubleFromObj.3$Z
fi
if test -r DumpActiveMemory.3; then
rm -f DumpActiveMemory.3.*
$ZIP DumpActiveMemory.3
rm -f Tcl_DumpActiveMemory.3 Tcl_DumpActiveMemory.3.*
rm -f Tcl_InitMemory.3 Tcl_InitMemory.3.*
rm -f Tcl_ValidateAllMemory.3 Tcl_ValidateAllMemory.3.*
ln $S DumpActiveMemory.3$Z Tcl_DumpActiveMemory.3$Z
ln $S DumpActiveMemory.3$Z Tcl_InitMemory.3$Z
ln $S DumpActiveMemory.3$Z Tcl_ValidateAllMemory.3$Z
fi
if test -r Encoding.3; then
rm -f Encoding.3.*
$ZIP Encoding.3
rm -f Tcl_GetEncoding.3 Tcl_GetEncoding.3.*
rm -f Tcl_FreeEncoding.3 Tcl_FreeEncoding.3.*
rm -f Tcl_ExternalToUtfDString.3 Tcl_ExternalToUtfDString.3.*
rm -f Tcl_ExternalToUtf.3 Tcl_ExternalToUtf.3.*
rm -f Tcl_UtfToExternalDString.3 Tcl_UtfToExternalDString.3.*
rm -f Tcl_UtfToExternal.3 Tcl_UtfToExternal.3.*
rm -f Tcl_WinTCharToUtf.3 Tcl_WinTCharToUtf.3.*
rm -f Tcl_WinUtfToTChar.3 Tcl_WinUtfToTChar.3.*
rm -f Tcl_GetEncodingName.3 Tcl_GetEncodingName.3.*
rm -f Tcl_SetSystemEncoding.3 Tcl_SetSystemEncoding.3.*
rm -f Tcl_GetEncodingNames.3 Tcl_GetEncodingNames.3.*
rm -f Tcl_CreateEncoding.3 Tcl_CreateEncoding.3.*
rm -f Tcl_GetDefaultEncodingDir.3 Tcl_GetDefaultEncodingDir.3.*
rm -f Tcl_SetDefaultEncodingDir.3 Tcl_SetDefaultEncodingDir.3.*
ln $S Encoding.3$Z Tcl_GetEncoding.3$Z
ln $S Encoding.3$Z Tcl_FreeEncoding.3$Z
ln $S Encoding.3$Z Tcl_ExternalToUtfDString.3$Z
ln $S Encoding.3$Z Tcl_ExternalToUtf.3$Z
ln $S Encoding.3$Z Tcl_UtfToExternalDString.3$Z
ln $S Encoding.3$Z Tcl_UtfToExternal.3$Z
ln $S Encoding.3$Z Tcl_WinTCharToUtf.3$Z
ln $S Encoding.3$Z Tcl_WinUtfToTChar.3$Z
ln $S Encoding.3$Z Tcl_GetEncodingName.3$Z
ln $S Encoding.3$Z Tcl_SetSystemEncoding.3$Z
ln $S Encoding.3$Z Tcl_GetEncodingNames.3$Z
ln $S Encoding.3$Z Tcl_CreateEncoding.3$Z
ln $S Encoding.3$Z Tcl_GetDefaultEncodingDir.3$Z
ln $S Encoding.3$Z Tcl_SetDefaultEncodingDir.3$Z
fi
if test -r Environment.3; then
rm -f Environment.3.*
$ZIP Environment.3
rm -f Tcl_PutEnv.3 Tcl_PutEnv.3.*
ln $S Environment.3$Z Tcl_PutEnv.3$Z
fi
if test -r Eval.3; then
rm -f Eval.3.*
$ZIP Eval.3
rm -f Tcl_EvalObjEx.3 Tcl_EvalObjEx.3.*
rm -f Tcl_EvalFile.3 Tcl_EvalFile.3.*
rm -f Tcl_EvalObjv.3 Tcl_EvalObjv.3.*
rm -f Tcl_Eval.3 Tcl_Eval.3.*
rm -f Tcl_EvalEx.3 Tcl_EvalEx.3.*
rm -f Tcl_GlobalEval.3 Tcl_GlobalEval.3.*
rm -f Tcl_GlobalEvalObj.3 Tcl_GlobalEvalObj.3.*
rm -f Tcl_VarEval.3 Tcl_VarEval.3.*
rm -f Tcl_VarEvalVA.3 Tcl_VarEvalVA.3.*
ln $S Eval.3$Z Tcl_EvalObjEx.3$Z
ln $S Eval.3$Z Tcl_EvalFile.3$Z
ln $S Eval.3$Z Tcl_EvalObjv.3$Z
ln $S Eval.3$Z Tcl_Eval.3$Z
ln $S Eval.3$Z Tcl_EvalEx.3$Z
ln $S Eval.3$Z Tcl_GlobalEval.3$Z
ln $S Eval.3$Z Tcl_GlobalEvalObj.3$Z
ln $S Eval.3$Z Tcl_VarEval.3$Z
ln $S Eval.3$Z Tcl_VarEvalVA.3$Z
fi
if test -r Exit.3; then
rm -f Exit.3.*
$ZIP Exit.3
rm -f Tcl_Exit.3 Tcl_Exit.3.*
rm -f Tcl_Finalize.3 Tcl_Finalize.3.*
rm -f Tcl_CreateExitHandler.3 Tcl_CreateExitHandler.3.*
rm -f Tcl_DeleteExitHandler.3 Tcl_DeleteExitHandler.3.*
rm -f Tcl_ExitThread.3 Tcl_ExitThread.3.*
rm -f Tcl_FinalizeThread.3 Tcl_FinalizeThread.3.*
rm -f Tcl_CreateThreadExitHandler.3 Tcl_CreateThreadExitHandler.3.*
rm -f Tcl_DeleteThreadExitHandler.3 Tcl_DeleteThreadExitHandler.3.*
ln $S Exit.3$Z Tcl_Exit.3$Z
ln $S Exit.3$Z Tcl_Finalize.3$Z
ln $S Exit.3$Z Tcl_CreateExitHandler.3$Z
ln $S Exit.3$Z Tcl_DeleteExitHandler.3$Z
ln $S Exit.3$Z Tcl_ExitThread.3$Z
ln $S Exit.3$Z Tcl_FinalizeThread.3$Z
ln $S Exit.3$Z Tcl_CreateThreadExitHandler.3$Z
ln $S Exit.3$Z Tcl_DeleteThreadExitHandler.3$Z
fi
if test -r ExprLong.3; then
rm -f ExprLong.3.*
$ZIP ExprLong.3
rm -f Tcl_ExprLong.3 Tcl_ExprLong.3.*
rm -f Tcl_ExprDouble.3 Tcl_ExprDouble.3.*
rm -f Tcl_ExprBoolean.3 Tcl_ExprBoolean.3.*
rm -f Tcl_ExprString.3 Tcl_ExprString.3.*
ln $S ExprLong.3$Z Tcl_ExprLong.3$Z
ln $S ExprLong.3$Z Tcl_ExprDouble.3$Z
ln $S ExprLong.3$Z Tcl_ExprBoolean.3$Z
ln $S ExprLong.3$Z Tcl_ExprString.3$Z
fi
if test -r ExprLongObj.3; then
rm -f ExprLongObj.3.*
$ZIP ExprLongObj.3
rm -f Tcl_ExprLongObj.3 Tcl_ExprLongObj.3.*
rm -f Tcl_ExprDoubleObj.3 Tcl_ExprDoubleObj.3.*
rm -f Tcl_ExprBooleanObj.3 Tcl_ExprBooleanObj.3.*
rm -f Tcl_ExprObj.3 Tcl_ExprObj.3.*
ln $S ExprLongObj.3$Z Tcl_ExprLongObj.3$Z
ln $S ExprLongObj.3$Z Tcl_ExprDoubleObj.3$Z
ln $S ExprLongObj.3$Z Tcl_ExprBooleanObj.3$Z
ln $S ExprLongObj.3$Z Tcl_ExprObj.3$Z
fi
if test -r FileSystem.3; then
rm -f FileSystem.3.*
$ZIP FileSystem.3
rm -f Tcl_FSRegister.3 Tcl_FSRegister.3.*
rm -f Tcl_FSUnregister.3 Tcl_FSUnregister.3.*
rm -f Tcl_FSData.3 Tcl_FSData.3.*
rm -f Tcl_FSMountsChanged.3 Tcl_FSMountsChanged.3.*
rm -f Tcl_FSGetFileSystemForPath.3 Tcl_FSGetFileSystemForPath.3.*
rm -f Tcl_FSGetPathType.3 Tcl_FSGetPathType.3.*
rm -f Tcl_FSCopyFile.3 Tcl_FSCopyFile.3.*
rm -f Tcl_FSCopyDirectory.3 Tcl_FSCopyDirectory.3.*
rm -f Tcl_FSCreateDirectory.3 Tcl_FSCreateDirectory.3.*
rm -f Tcl_FSDeleteFile.3 Tcl_FSDeleteFile.3.*
rm -f Tcl_FSRemoveDirectory.3 Tcl_FSRemoveDirectory.3.*
rm -f Tcl_FSRenameFile.3 Tcl_FSRenameFile.3.*
rm -f Tcl_FSListVolumes.3 Tcl_FSListVolumes.3.*
rm -f Tcl_FSEvalFile.3 Tcl_FSEvalFile.3.*
rm -f Tcl_FSLoadFile.3 Tcl_FSLoadFile.3.*
rm -f Tcl_FSMatchInDirectory.3 Tcl_FSMatchInDirectory.3.*
rm -f Tcl_FSLink.3 Tcl_FSLink.3.*
rm -f Tcl_FSLstat.3 Tcl_FSLstat.3.*
rm -f Tcl_FSUtime.3 Tcl_FSUtime.3.*
rm -f Tcl_FSFileAttrsGet.3 Tcl_FSFileAttrsGet.3.*
rm -f Tcl_FSFileAttrsSet.3 Tcl_FSFileAttrsSet.3.*
rm -f Tcl_FSFileAttrStrings.3 Tcl_FSFileAttrStrings.3.*
rm -f Tcl_FSStat.3 Tcl_FSStat.3.*
rm -f Tcl_FSAccess.3 Tcl_FSAccess.3.*
rm -f Tcl_FSOpenFileChannel.3 Tcl_FSOpenFileChannel.3.*
rm -f Tcl_FSGetCwd.3 Tcl_FSGetCwd.3.*
rm -f Tcl_FSChdir.3 Tcl_FSChdir.3.*
rm -f Tcl_FSPathSeparator.3 Tcl_FSPathSeparator.3.*
rm -f Tcl_FSJoinPath.3 Tcl_FSJoinPath.3.*
rm -f Tcl_FSSplitPath.3 Tcl_FSSplitPath.3.*
rm -f Tcl_FSEqualPaths.3 Tcl_FSEqualPaths.3.*
rm -f Tcl_FSGetNormalizedPath.3 Tcl_FSGetNormalizedPath.3.*
rm -f Tcl_FSJoinToPath.3 Tcl_FSJoinToPath.3.*
rm -f Tcl_FSConvertToPathType.3 Tcl_FSConvertToPathType.3.*
rm -f Tcl_FSGetInternalRep.3 Tcl_FSGetInternalRep.3.*
rm -f Tcl_FSGetTranslatedPath.3 Tcl_FSGetTranslatedPath.3.*
rm -f Tcl_FSGetTranslatedStringPath.3 Tcl_FSGetTranslatedStringPath.3.*
rm -f Tcl_FSNewNativePath.3 Tcl_FSNewNativePath.3.*
rm -f Tcl_FSGetNativePath.3 Tcl_FSGetNativePath.3.*
rm -f Tcl_FSFileSystemInfo.3 Tcl_FSFileSystemInfo.3.*
rm -f Tcl_AllocStatBuf.3 Tcl_AllocStatBuf.3.*
ln $S FileSystem.3$Z Tcl_FSRegister.3$Z
ln $S FileSystem.3$Z Tcl_FSUnregister.3$Z
ln $S FileSystem.3$Z Tcl_FSData.3$Z
ln $S FileSystem.3$Z Tcl_FSMountsChanged.3$Z
ln $S FileSystem.3$Z Tcl_FSGetFileSystemForPath.3$Z
ln $S FileSystem.3$Z Tcl_FSGetPathType.3$Z
ln $S FileSystem.3$Z Tcl_FSCopyFile.3$Z
ln $S FileSystem.3$Z Tcl_FSCopyDirectory.3$Z
ln $S FileSystem.3$Z Tcl_FSCreateDirectory.3$Z
ln $S FileSystem.3$Z Tcl_FSDeleteFile.3$Z
ln $S FileSystem.3$Z Tcl_FSRemoveDirectory.3$Z
ln $S FileSystem.3$Z Tcl_FSRenameFile.3$Z
ln $S FileSystem.3$Z Tcl_FSListVolumes.3$Z
ln $S FileSystem.3$Z Tcl_FSEvalFile.3$Z
ln $S FileSystem.3$Z Tcl_FSLoadFile.3$Z
ln $S FileSystem.3$Z Tcl_FSMatchInDirectory.3$Z
ln $S FileSystem.3$Z Tcl_FSLink.3$Z
ln $S FileSystem.3$Z Tcl_FSLstat.3$Z
ln $S FileSystem.3$Z Tcl_FSUtime.3$Z
ln $S FileSystem.3$Z Tcl_FSFileAttrsGet.3$Z
ln $S FileSystem.3$Z Tcl_FSFileAttrsSet.3$Z
ln $S FileSystem.3$Z Tcl_FSFileAttrStrings.3$Z
ln $S FileSystem.3$Z Tcl_FSStat.3$Z
ln $S FileSystem.3$Z Tcl_FSAccess.3$Z
ln $S FileSystem.3$Z Tcl_FSOpenFileChannel.3$Z
ln $S FileSystem.3$Z Tcl_FSGetCwd.3$Z
ln $S FileSystem.3$Z Tcl_FSChdir.3$Z
ln $S FileSystem.3$Z Tcl_FSPathSeparator.3$Z
ln $S FileSystem.3$Z Tcl_FSJoinPath.3$Z
ln $S FileSystem.3$Z Tcl_FSSplitPath.3$Z
ln $S FileSystem.3$Z Tcl_FSEqualPaths.3$Z
ln $S FileSystem.3$Z Tcl_FSGetNormalizedPath.3$Z
ln $S FileSystem.3$Z Tcl_FSJoinToPath.3$Z
ln $S FileSystem.3$Z Tcl_FSConvertToPathType.3$Z
ln $S FileSystem.3$Z Tcl_FSGetInternalRep.3$Z
ln $S FileSystem.3$Z Tcl_FSGetTranslatedPath.3$Z
ln $S FileSystem.3$Z Tcl_FSGetTranslatedStringPath.3$Z
ln $S FileSystem.3$Z Tcl_FSNewNativePath.3$Z
ln $S FileSystem.3$Z Tcl_FSGetNativePath.3$Z
ln $S FileSystem.3$Z Tcl_FSFileSystemInfo.3$Z
ln $S FileSystem.3$Z Tcl_AllocStatBuf.3$Z
fi
if test -r FindExec.3; then
rm -f FindExec.3.*
$ZIP FindExec.3
rm -f Tcl_FindExecutable.3 Tcl_FindExecutable.3.*
rm -f Tcl_GetNameOfExecutable.3 Tcl_GetNameOfExecutable.3.*
ln $S FindExec.3$Z Tcl_FindExecutable.3$Z
ln $S FindExec.3$Z Tcl_GetNameOfExecutable.3$Z
fi
if test -r GetCwd.3; then
rm -f GetCwd.3.*
$ZIP GetCwd.3
rm -f Tcl_GetCwd.3 Tcl_GetCwd.3.*
rm -f Tcl_Chdir.3 Tcl_Chdir.3.*
ln $S GetCwd.3$Z Tcl_GetCwd.3$Z
ln $S GetCwd.3$Z Tcl_Chdir.3$Z
fi
if test -r GetHostName.3; then
rm -f GetHostName.3.*
$ZIP GetHostName.3
rm -f Tcl_GetHostName.3 Tcl_GetHostName.3.*
ln $S GetHostName.3$Z Tcl_GetHostName.3$Z
fi
if test -r GetIndex.3; then
rm -f GetIndex.3.*
$ZIP GetIndex.3
rm -f Tcl_GetIndexFromObj.3 Tcl_GetIndexFromObj.3.*
rm -f Tcl_GetIndexFromObjStruct.3 Tcl_GetIndexFromObjStruct.3.*
ln $S GetIndex.3$Z Tcl_GetIndexFromObj.3$Z
ln $S GetIndex.3$Z Tcl_GetIndexFromObjStruct.3$Z
fi
if test -r GetInt.3; then
rm -f GetInt.3.*
$ZIP GetInt.3
rm -f Tcl_GetInt.3 Tcl_GetInt.3.*
rm -f Tcl_GetDouble.3 Tcl_GetDouble.3.*
rm -f Tcl_GetBoolean.3 Tcl_GetBoolean.3.*
ln $S GetInt.3$Z Tcl_GetInt.3$Z
ln $S GetInt.3$Z Tcl_GetDouble.3$Z
ln $S GetInt.3$Z Tcl_GetBoolean.3$Z
fi
if test -r GetOpnFl.3; then
rm -f GetOpnFl.3.*
$ZIP GetOpnFl.3
rm -f Tcl_GetOpenFile.3 Tcl_GetOpenFile.3.*
ln $S GetOpnFl.3$Z Tcl_GetOpenFile.3$Z
fi
if test -r GetStdChan.3; then
rm -f GetStdChan.3.*
$ZIP GetStdChan.3
rm -f Tcl_GetStdChannel.3 Tcl_GetStdChannel.3.*
rm -f Tcl_SetStdChannel.3 Tcl_SetStdChannel.3.*
ln $S GetStdChan.3$Z Tcl_GetStdChannel.3$Z
ln $S GetStdChan.3$Z Tcl_SetStdChannel.3$Z
fi
if test -r GetTime.3; then
rm -f GetTime.3.*
$ZIP GetTime.3
rm -f Tcl_GetTime.3 Tcl_GetTime.3.*
ln $S GetTime.3$Z Tcl_GetTime.3$Z
fi
if test -r GetVersion.3; then
rm -f GetVersion.3.*
$ZIP GetVersion.3
rm -f Tcl_GetVersion.3 Tcl_GetVersion.3.*
ln $S GetVersion.3$Z Tcl_GetVersion.3$Z
fi
if test -r Hash.3; then
rm -f Hash.3.*
$ZIP Hash.3
rm -f Tcl_InitHashTable.3 Tcl_InitHashTable.3.*
rm -f Tcl_InitCustomHashTable.3 Tcl_InitCustomHashTable.3.*
rm -f Tcl_InitObjHashTable.3 Tcl_InitObjHashTable.3.*
rm -f Tcl_DeleteHashTable.3 Tcl_DeleteHashTable.3.*
rm -f Tcl_CreateHashEntry.3 Tcl_CreateHashEntry.3.*
rm -f Tcl_DeleteHashEntry.3 Tcl_DeleteHashEntry.3.*
rm -f Tcl_FindHashEntry.3 Tcl_FindHashEntry.3.*
rm -f Tcl_GetHashValue.3 Tcl_GetHashValue.3.*
rm -f Tcl_SetHashValue.3 Tcl_SetHashValue.3.*
rm -f Tcl_GetHashKey.3 Tcl_GetHashKey.3.*
rm -f Tcl_FirstHashEntry.3 Tcl_FirstHashEntry.3.*
rm -f Tcl_NextHashEntry.3 Tcl_NextHashEntry.3.*
rm -f Tcl_HashStats.3 Tcl_HashStats.3.*
ln $S Hash.3$Z Tcl_InitHashTable.3$Z
ln $S Hash.3$Z Tcl_InitCustomHashTable.3$Z
ln $S Hash.3$Z Tcl_InitObjHashTable.3$Z
ln $S Hash.3$Z Tcl_DeleteHashTable.3$Z
ln $S Hash.3$Z Tcl_CreateHashEntry.3$Z
ln $S Hash.3$Z Tcl_DeleteHashEntry.3$Z
ln $S Hash.3$Z Tcl_FindHashEntry.3$Z
ln $S Hash.3$Z Tcl_GetHashValue.3$Z
ln $S Hash.3$Z Tcl_SetHashValue.3$Z
ln $S Hash.3$Z Tcl_GetHashKey.3$Z
ln $S Hash.3$Z Tcl_FirstHashEntry.3$Z
ln $S Hash.3$Z Tcl_NextHashEntry.3$Z
ln $S Hash.3$Z Tcl_HashStats.3$Z
fi
if test -r Init.3; then
rm -f Init.3.*
$ZIP Init.3
rm -f Tcl_Init.3 Tcl_Init.3.*
ln $S Init.3$Z Tcl_Init.3$Z
fi
if test -r InitStubs.3; then
rm -f InitStubs.3.*
$ZIP InitStubs.3
rm -f Tcl_InitStubs.3 Tcl_InitStubs.3.*
ln $S InitStubs.3$Z Tcl_InitStubs.3$Z
fi
if test -r IntObj.3; then
rm -f IntObj.3.*
$ZIP IntObj.3
rm -f Tcl_NewIntObj.3 Tcl_NewIntObj.3.*
rm -f Tcl_NewLongObj.3 Tcl_NewLongObj.3.*
rm -f Tcl_NewWideIntObj.3 Tcl_NewWideIntObj.3.*
rm -f Tcl_SetIntObj.3 Tcl_SetIntObj.3.*
rm -f Tcl_SetLongObj.3 Tcl_SetLongObj.3.*
rm -f Tcl_SetWideIntObj.3 Tcl_SetWideIntObj.3.*
rm -f Tcl_GetIntFromObj.3 Tcl_GetIntFromObj.3.*
rm -f Tcl_GetLongFromObj.3 Tcl_GetLongFromObj.3.*
rm -f Tcl_GetWideIntFromObj.3 Tcl_GetWideIntFromObj.3.*
ln $S IntObj.3$Z Tcl_NewIntObj.3$Z
ln $S IntObj.3$Z Tcl_NewLongObj.3$Z
ln $S IntObj.3$Z Tcl_NewWideIntObj.3$Z
ln $S IntObj.3$Z Tcl_SetIntObj.3$Z
ln $S IntObj.3$Z Tcl_SetLongObj.3$Z
ln $S IntObj.3$Z Tcl_SetWideIntObj.3$Z
ln $S IntObj.3$Z Tcl_GetIntFromObj.3$Z
ln $S IntObj.3$Z Tcl_GetLongFromObj.3$Z
ln $S IntObj.3$Z Tcl_GetWideIntFromObj.3$Z
fi
if test -r Interp.3; then
rm -f Interp.3.*
$ZIP Interp.3
rm -f Tcl_Interp.3 Tcl_Interp.3.*
ln $S Interp.3$Z Tcl_Interp.3$Z
fi
if test -r LinkVar.3; then
rm -f LinkVar.3.*
$ZIP LinkVar.3
rm -f Tcl_LinkVar.3 Tcl_LinkVar.3.*
rm -f Tcl_UnlinkVar.3 Tcl_UnlinkVar.3.*
rm -f Tcl_UpdateLinkedVar.3 Tcl_UpdateLinkedVar.3.*
ln $S LinkVar.3$Z Tcl_LinkVar.3$Z
ln $S LinkVar.3$Z Tcl_UnlinkVar.3$Z
ln $S LinkVar.3$Z Tcl_UpdateLinkedVar.3$Z
fi
if test -r ListObj.3; then
rm -f ListObj.3.*
$ZIP ListObj.3
rm -f Tcl_ListObjAppendList.3 Tcl_ListObjAppendList.3.*
rm -f Tcl_ListObjAppendElement.3 Tcl_ListObjAppendElement.3.*
rm -f Tcl_NewListObj.3 Tcl_NewListObj.3.*
rm -f Tcl_SetListObj.3 Tcl_SetListObj.3.*
rm -f Tcl_ListObjGetElements.3 Tcl_ListObjGetElements.3.*
rm -f Tcl_ListObjLength.3 Tcl_ListObjLength.3.*
rm -f Tcl_ListObjIndex.3 Tcl_ListObjIndex.3.*
rm -f Tcl_ListObjReplace.3 Tcl_ListObjReplace.3.*
ln $S ListObj.3$Z Tcl_ListObjAppendList.3$Z
ln $S ListObj.3$Z Tcl_ListObjAppendElement.3$Z
ln $S ListObj.3$Z Tcl_NewListObj.3$Z
ln $S ListObj.3$Z Tcl_SetListObj.3$Z
ln $S ListObj.3$Z Tcl_ListObjGetElements.3$Z
ln $S ListObj.3$Z Tcl_ListObjLength.3$Z
ln $S ListObj.3$Z Tcl_ListObjIndex.3$Z
ln $S ListObj.3$Z Tcl_ListObjReplace.3$Z
fi
if test -r Macintosh.3; then
rm -f Macintosh.3.*
$ZIP Macintosh.3
rm -f Tcl_MacSetEventProc.3 Tcl_MacSetEventProc.3.*
rm -f Tcl_MacConvertTextResource.3 Tcl_MacConvertTextResource.3.*
rm -f Tcl_MacEvalResource.3 Tcl_MacEvalResource.3.*
rm -f Tcl_MacFindResource.3 Tcl_MacFindResource.3.*
rm -f Tcl_GetOSTypeFromObj.3 Tcl_GetOSTypeFromObj.3.*
rm -f Tcl_SetOSTypeObj.3 Tcl_SetOSTypeObj.3.*
rm -f Tcl_NewOSTypeObj.3 Tcl_NewOSTypeObj.3.*
ln $S Macintosh.3$Z Tcl_MacSetEventProc.3$Z
ln $S Macintosh.3$Z Tcl_MacConvertTextResource.3$Z
ln $S Macintosh.3$Z Tcl_MacEvalResource.3$Z
ln $S Macintosh.3$Z Tcl_MacFindResource.3$Z
ln $S Macintosh.3$Z Tcl_GetOSTypeFromObj.3$Z
ln $S Macintosh.3$Z Tcl_SetOSTypeObj.3$Z
ln $S Macintosh.3$Z Tcl_NewOSTypeObj.3$Z
fi
if test -r Notifier.3; then
rm -f Notifier.3.*
$ZIP Notifier.3
rm -f Tcl_CreateEventSource.3 Tcl_CreateEventSource.3.*
rm -f Tcl_DeleteEventSource.3 Tcl_DeleteEventSource.3.*
rm -f Tcl_SetMaxBlockTime.3 Tcl_SetMaxBlockTime.3.*
rm -f Tcl_QueueEvent.3 Tcl_QueueEvent.3.*
rm -f Tcl_ThreadQueueEvent.3 Tcl_ThreadQueueEvent.3.*
rm -f Tcl_ThreadAlert.3 Tcl_ThreadAlert.3.*
rm -f Tcl_GetCurrentThread.3 Tcl_GetCurrentThread.3.*
rm -f Tcl_DeleteEvents.3 Tcl_DeleteEvents.3.*
rm -f Tcl_InitNotifier.3 Tcl_InitNotifier.3.*
rm -f Tcl_FinalizeNotifier.3 Tcl_FinalizeNotifier.3.*
rm -f Tcl_WaitForEvent.3 Tcl_WaitForEvent.3.*
rm -f Tcl_AlertNotifier.3 Tcl_AlertNotifier.3.*
rm -f Tcl_SetTimer.3 Tcl_SetTimer.3.*
rm -f Tcl_ServiceAll.3 Tcl_ServiceAll.3.*
rm -f Tcl_ServiceEvent.3 Tcl_ServiceEvent.3.*
rm -f Tcl_GetServiceMode.3 Tcl_GetServiceMode.3.*
rm -f Tcl_SetServiceMode.3 Tcl_SetServiceMode.3.*
ln $S Notifier.3$Z Tcl_CreateEventSource.3$Z
ln $S Notifier.3$Z Tcl_DeleteEventSource.3$Z
ln $S Notifier.3$Z Tcl_SetMaxBlockTime.3$Z
ln $S Notifier.3$Z Tcl_QueueEvent.3$Z
ln $S Notifier.3$Z Tcl_ThreadQueueEvent.3$Z
ln $S Notifier.3$Z Tcl_ThreadAlert.3$Z
ln $S Notifier.3$Z Tcl_GetCurrentThread.3$Z
ln $S Notifier.3$Z Tcl_DeleteEvents.3$Z
ln $S Notifier.3$Z Tcl_InitNotifier.3$Z
ln $S Notifier.3$Z Tcl_FinalizeNotifier.3$Z
ln $S Notifier.3$Z Tcl_WaitForEvent.3$Z
ln $S Notifier.3$Z Tcl_AlertNotifier.3$Z
ln $S Notifier.3$Z Tcl_SetTimer.3$Z
ln $S Notifier.3$Z Tcl_ServiceAll.3$Z
ln $S Notifier.3$Z Tcl_ServiceEvent.3$Z
ln $S Notifier.3$Z Tcl_GetServiceMode.3$Z
ln $S Notifier.3$Z Tcl_SetServiceMode.3$Z
fi
if test -r Object.3; then
rm -f Object.3.*
$ZIP Object.3
rm -f Tcl_NewObj.3 Tcl_NewObj.3.*
rm -f Tcl_DuplicateObj.3 Tcl_DuplicateObj.3.*
rm -f Tcl_IncrRefCount.3 Tcl_IncrRefCount.3.*
rm -f Tcl_DecrRefCount.3 Tcl_DecrRefCount.3.*
rm -f Tcl_IsShared.3 Tcl_IsShared.3.*
rm -f Tcl_InvalidateStringRep.3 Tcl_InvalidateStringRep.3.*
ln $S Object.3$Z Tcl_NewObj.3$Z
ln $S Object.3$Z Tcl_DuplicateObj.3$Z
ln $S Object.3$Z Tcl_IncrRefCount.3$Z
ln $S Object.3$Z Tcl_DecrRefCount.3$Z
ln $S Object.3$Z Tcl_IsShared.3$Z
ln $S Object.3$Z Tcl_InvalidateStringRep.3$Z
fi
if test -r ObjectType.3; then
rm -f ObjectType.3.*
$ZIP ObjectType.3
rm -f Tcl_RegisterObjType.3 Tcl_RegisterObjType.3.*
rm -f Tcl_GetObjType.3 Tcl_GetObjType.3.*
rm -f Tcl_AppendAllObjTypes.3 Tcl_AppendAllObjTypes.3.*
rm -f Tcl_ConvertToType.3 Tcl_ConvertToType.3.*
ln $S ObjectType.3$Z Tcl_RegisterObjType.3$Z
ln $S ObjectType.3$Z Tcl_GetObjType.3$Z
ln $S ObjectType.3$Z Tcl_AppendAllObjTypes.3$Z
ln $S ObjectType.3$Z Tcl_ConvertToType.3$Z
fi
if test -r OpenFileChnl.3; then
rm -f OpenFileChnl.3.*
$ZIP OpenFileChnl.3
rm -f Tcl_OpenFileChannel.3 Tcl_OpenFileChannel.3.*
rm -f Tcl_OpenCommandChannel.3 Tcl_OpenCommandChannel.3.*
rm -f Tcl_MakeFileChannel.3 Tcl_MakeFileChannel.3.*
rm -f Tcl_GetChannel.3 Tcl_GetChannel.3.*
rm -f Tcl_GetChannelNames.3 Tcl_GetChannelNames.3.*
rm -f Tcl_GetChannelNamesEx.3 Tcl_GetChannelNamesEx.3.*
rm -f Tcl_RegisterChannel.3 Tcl_RegisterChannel.3.*
rm -f Tcl_UnregisterChannel.3 Tcl_UnregisterChannel.3.*
rm -f Tcl_DetachChannel.3 Tcl_DetachChannel.3.*
rm -f Tcl_IsStandardChannel.3 Tcl_IsStandardChannel.3.*
rm -f Tcl_Close.3 Tcl_Close.3.*
rm -f Tcl_ReadChars.3 Tcl_ReadChars.3.*
rm -f Tcl_Read.3 Tcl_Read.3.*
rm -f Tcl_GetsObj.3 Tcl_GetsObj.3.*
rm -f Tcl_Gets.3 Tcl_Gets.3.*
rm -f Tcl_WriteObj.3 Tcl_WriteObj.3.*
rm -f Tcl_WriteChars.3 Tcl_WriteChars.3.*
rm -f Tcl_Write.3 Tcl_Write.3.*
rm -f Tcl_Flush.3 Tcl_Flush.3.*
rm -f Tcl_Seek.3 Tcl_Seek.3.*
rm -f Tcl_Tell.3 Tcl_Tell.3.*
rm -f Tcl_GetChannelOption.3 Tcl_GetChannelOption.3.*
rm -f Tcl_SetChannelOption.3 Tcl_SetChannelOption.3.*
rm -f Tcl_Eof.3 Tcl_Eof.3.*
rm -f Tcl_InputBlocked.3 Tcl_InputBlocked.3.*
rm -f Tcl_InputBuffered.3 Tcl_InputBuffered.3.*
rm -f Tcl_OutputBuffered.3 Tcl_OutputBuffered.3.*
rm -f Tcl_Ungets.3 Tcl_Ungets.3.*
rm -f Tcl_ReadRaw.3 Tcl_ReadRaw.3.*
rm -f Tcl_WriteRaw.3 Tcl_WriteRaw.3.*
ln $S OpenFileChnl.3$Z Tcl_OpenFileChannel.3$Z
ln $S OpenFileChnl.3$Z Tcl_OpenCommandChannel.3$Z
ln $S OpenFileChnl.3$Z Tcl_MakeFileChannel.3$Z
ln $S OpenFileChnl.3$Z Tcl_GetChannel.3$Z
ln $S OpenFileChnl.3$Z Tcl_GetChannelNames.3$Z
ln $S OpenFileChnl.3$Z Tcl_GetChannelNamesEx.3$Z
ln $S OpenFileChnl.3$Z Tcl_RegisterChannel.3$Z
ln $S OpenFileChnl.3$Z Tcl_UnregisterChannel.3$Z
ln $S OpenFileChnl.3$Z Tcl_DetachChannel.3$Z
ln $S OpenFileChnl.3$Z Tcl_IsStandardChannel.3$Z
ln $S OpenFileChnl.3$Z Tcl_Close.3$Z
ln $S OpenFileChnl.3$Z Tcl_ReadChars.3$Z
ln $S OpenFileChnl.3$Z Tcl_Read.3$Z
ln $S OpenFileChnl.3$Z Tcl_GetsObj.3$Z
ln $S OpenFileChnl.3$Z Tcl_Gets.3$Z
ln $S OpenFileChnl.3$Z Tcl_WriteObj.3$Z
ln $S OpenFileChnl.3$Z Tcl_WriteChars.3$Z
ln $S OpenFileChnl.3$Z Tcl_Write.3$Z
ln $S OpenFileChnl.3$Z Tcl_Flush.3$Z
ln $S OpenFileChnl.3$Z Tcl_Seek.3$Z
ln $S OpenFileChnl.3$Z Tcl_Tell.3$Z
ln $S OpenFileChnl.3$Z Tcl_GetChannelOption.3$Z
ln $S OpenFileChnl.3$Z Tcl_SetChannelOption.3$Z
ln $S OpenFileChnl.3$Z Tcl_Eof.3$Z
ln $S OpenFileChnl.3$Z Tcl_InputBlocked.3$Z
ln $S OpenFileChnl.3$Z Tcl_InputBuffered.3$Z
ln $S OpenFileChnl.3$Z Tcl_OutputBuffered.3$Z
ln $S OpenFileChnl.3$Z Tcl_Ungets.3$Z
ln $S OpenFileChnl.3$Z Tcl_ReadRaw.3$Z
ln $S OpenFileChnl.3$Z Tcl_WriteRaw.3$Z
fi
if test -r OpenTcp.3; then
rm -f OpenTcp.3.*
$ZIP OpenTcp.3
rm -f Tcl_OpenTcpClient.3 Tcl_OpenTcpClient.3.*
rm -f Tcl_MakeTcpClientChannel.3 Tcl_MakeTcpClientChannel.3.*
rm -f Tcl_OpenTcpServer.3 Tcl_OpenTcpServer.3.*
ln $S OpenTcp.3$Z Tcl_OpenTcpClient.3$Z
ln $S OpenTcp.3$Z Tcl_MakeTcpClientChannel.3$Z
ln $S OpenTcp.3$Z Tcl_OpenTcpServer.3$Z
fi
if test -r Panic.3; then
rm -f Panic.3.*
$ZIP Panic.3
rm -f Tcl_Panic.3 Tcl_Panic.3.*
rm -f Tcl_PanicVA.3 Tcl_PanicVA.3.*
rm -f Tcl_SetPanicProc.3 Tcl_SetPanicProc.3.*
if test "${CASEINSENSITIVEFS:-}" != "1"; then rm -f panic.3 panic.3.* ; fi
rm -f panicVA.3 panicVA.3.*
ln $S Panic.3$Z Tcl_Panic.3$Z
ln $S Panic.3$Z Tcl_PanicVA.3$Z
ln $S Panic.3$Z Tcl_SetPanicProc.3$Z
if test "${CASEINSENSITIVEFS:-}" != "1"; then ln $S Panic.3$Z panic.3$Z ; fi
ln $S Panic.3$Z panicVA.3$Z
fi
if test -r ParseCmd.3; then
rm -f ParseCmd.3.*
$ZIP ParseCmd.3
rm -f Tcl_ParseCommand.3 Tcl_ParseCommand.3.*
rm -f Tcl_ParseExpr.3 Tcl_ParseExpr.3.*
rm -f Tcl_ParseBraces.3 Tcl_ParseBraces.3.*
rm -f Tcl_ParseQuotedString.3 Tcl_ParseQuotedString.3.*
rm -f Tcl_ParseVarName.3 Tcl_ParseVarName.3.*
rm -f Tcl_ParseVar.3 Tcl_ParseVar.3.*
rm -f Tcl_FreeParse.3 Tcl_FreeParse.3.*
rm -f Tcl_EvalTokens.3 Tcl_EvalTokens.3.*
rm -f Tcl_EvalTokensStandard.3 Tcl_EvalTokensStandard.3.*
ln $S ParseCmd.3$Z Tcl_ParseCommand.3$Z
ln $S ParseCmd.3$Z Tcl_ParseExpr.3$Z
ln $S ParseCmd.3$Z Tcl_ParseBraces.3$Z
ln $S ParseCmd.3$Z Tcl_ParseQuotedString.3$Z
ln $S ParseCmd.3$Z Tcl_ParseVarName.3$Z
ln $S ParseCmd.3$Z Tcl_ParseVar.3$Z
ln $S ParseCmd.3$Z Tcl_FreeParse.3$Z
ln $S ParseCmd.3$Z Tcl_EvalTokens.3$Z
ln $S ParseCmd.3$Z Tcl_EvalTokensStandard.3$Z
fi
if test -r PkgRequire.3; then
rm -f PkgRequire.3.*
$ZIP PkgRequire.3
rm -f Tcl_PkgRequire.3 Tcl_PkgRequire.3.*
rm -f Tcl_PkgRequireEx.3 Tcl_PkgRequireEx.3.*
rm -f Tcl_PkgPresent.3 Tcl_PkgPresent.3.*
rm -f Tcl_PkgPresentEx.3 Tcl_PkgPresentEx.3.*
rm -f Tcl_PkgProvide.3 Tcl_PkgProvide.3.*
rm -f Tcl_PkgProvideEx.3 Tcl_PkgProvideEx.3.*
ln $S PkgRequire.3$Z Tcl_PkgRequire.3$Z
ln $S PkgRequire.3$Z Tcl_PkgRequireEx.3$Z
ln $S PkgRequire.3$Z Tcl_PkgPresent.3$Z
ln $S PkgRequire.3$Z Tcl_PkgPresentEx.3$Z
ln $S PkgRequire.3$Z Tcl_PkgProvide.3$Z
ln $S PkgRequire.3$Z Tcl_PkgProvideEx.3$Z
fi
if test -r Preserve.3; then
rm -f Preserve.3.*
$ZIP Preserve.3
rm -f Tcl_Preserve.3 Tcl_Preserve.3.*
rm -f Tcl_Release.3 Tcl_Release.3.*
rm -f Tcl_EventuallyFree.3 Tcl_EventuallyFree.3.*
ln $S Preserve.3$Z Tcl_Preserve.3$Z
ln $S Preserve.3$Z Tcl_Release.3$Z
ln $S Preserve.3$Z Tcl_EventuallyFree.3$Z
fi
if test -r PrintDbl.3; then
rm -f PrintDbl.3.*
$ZIP PrintDbl.3
rm -f Tcl_PrintDouble.3 Tcl_PrintDouble.3.*
ln $S PrintDbl.3$Z Tcl_PrintDouble.3$Z
fi
if test -r RecEvalObj.3; then
rm -f RecEvalObj.3.*
$ZIP RecEvalObj.3
rm -f Tcl_RecordAndEvalObj.3 Tcl_RecordAndEvalObj.3.*
ln $S RecEvalObj.3$Z Tcl_RecordAndEvalObj.3$Z
fi
if test -r RecordEval.3; then
rm -f RecordEval.3.*
$ZIP RecordEval.3
rm -f Tcl_RecordAndEval.3 Tcl_RecordAndEval.3.*
ln $S RecordEval.3$Z Tcl_RecordAndEval.3$Z
fi
if test -r RegExp.3; then
rm -f RegExp.3.*
$ZIP RegExp.3
rm -f Tcl_RegExpMatch.3 Tcl_RegExpMatch.3.*
rm -f Tcl_RegExpCompile.3 Tcl_RegExpCompile.3.*
rm -f Tcl_RegExpExec.3 Tcl_RegExpExec.3.*
rm -f Tcl_RegExpRange.3 Tcl_RegExpRange.3.*
rm -f Tcl_GetRegExpFromObj.3 Tcl_GetRegExpFromObj.3.*
rm -f Tcl_RegExpMatchObj.3 Tcl_RegExpMatchObj.3.*
rm -f Tcl_RegExpExecObj.3 Tcl_RegExpExecObj.3.*
rm -f Tcl_RegExpGetInfo.3 Tcl_RegExpGetInfo.3.*
ln $S RegExp.3$Z Tcl_RegExpMatch.3$Z
ln $S RegExp.3$Z Tcl_RegExpCompile.3$Z
ln $S RegExp.3$Z Tcl_RegExpExec.3$Z
ln $S RegExp.3$Z Tcl_RegExpRange.3$Z
ln $S RegExp.3$Z Tcl_GetRegExpFromObj.3$Z
ln $S RegExp.3$Z Tcl_RegExpMatchObj.3$Z
ln $S RegExp.3$Z Tcl_RegExpExecObj.3$Z
ln $S RegExp.3$Z Tcl_RegExpGetInfo.3$Z
fi
if test -r SaveResult.3; then
rm -f SaveResult.3.*
$ZIP SaveResult.3
rm -f Tcl_SaveResult.3 Tcl_SaveResult.3.*
rm -f Tcl_RestoreResult.3 Tcl_RestoreResult.3.*
rm -f Tcl_DiscardResult.3 Tcl_DiscardResult.3.*
ln $S SaveResult.3$Z Tcl_SaveResult.3$Z
ln $S SaveResult.3$Z Tcl_RestoreResult.3$Z
ln $S SaveResult.3$Z Tcl_DiscardResult.3$Z
fi
if test -r SetErrno.3; then
rm -f SetErrno.3.*
$ZIP SetErrno.3
rm -f Tcl_SetErrno.3 Tcl_SetErrno.3.*
rm -f Tcl_GetErrno.3 Tcl_GetErrno.3.*
rm -f Tcl_ErrnoId.3 Tcl_ErrnoId.3.*
rm -f Tcl_ErrnoMsg.3 Tcl_ErrnoMsg.3.*
ln $S SetErrno.3$Z Tcl_SetErrno.3$Z
ln $S SetErrno.3$Z Tcl_GetErrno.3$Z
ln $S SetErrno.3$Z Tcl_ErrnoId.3$Z
ln $S SetErrno.3$Z Tcl_ErrnoMsg.3$Z
fi
if test -r SetRecLmt.3; then
rm -f SetRecLmt.3.*
$ZIP SetRecLmt.3
rm -f Tcl_SetRecursionLimit.3 Tcl_SetRecursionLimit.3.*
ln $S SetRecLmt.3$Z Tcl_SetRecursionLimit.3$Z
fi
if test -r SetResult.3; then
rm -f SetResult.3.*
$ZIP SetResult.3
rm -f Tcl_SetObjResult.3 Tcl_SetObjResult.3.*
rm -f Tcl_GetObjResult.3 Tcl_GetObjResult.3.*
rm -f Tcl_SetResult.3 Tcl_SetResult.3.*
rm -f Tcl_GetStringResult.3 Tcl_GetStringResult.3.*
rm -f Tcl_AppendResult.3 Tcl_AppendResult.3.*
rm -f Tcl_AppendResultVA.3 Tcl_AppendResultVA.3.*
rm -f Tcl_AppendElement.3 Tcl_AppendElement.3.*
rm -f Tcl_ResetResult.3 Tcl_ResetResult.3.*
rm -f Tcl_FreeResult.3 Tcl_FreeResult.3.*
ln $S SetResult.3$Z Tcl_SetObjResult.3$Z
ln $S SetResult.3$Z Tcl_GetObjResult.3$Z
ln $S SetResult.3$Z Tcl_SetResult.3$Z
ln $S SetResult.3$Z Tcl_GetStringResult.3$Z
ln $S SetResult.3$Z Tcl_AppendResult.3$Z
ln $S SetResult.3$Z Tcl_AppendResultVA.3$Z
ln $S SetResult.3$Z Tcl_AppendElement.3$Z
ln $S SetResult.3$Z Tcl_ResetResult.3$Z
ln $S SetResult.3$Z Tcl_FreeResult.3$Z
fi
if test -r SetVar.3; then
rm -f SetVar.3.*
$ZIP SetVar.3
rm -f Tcl_SetVar2Ex.3 Tcl_SetVar2Ex.3.*
rm -f Tcl_SetVar.3 Tcl_SetVar.3.*
rm -f Tcl_SetVar2.3 Tcl_SetVar2.3.*
rm -f Tcl_ObjSetVar2.3 Tcl_ObjSetVar2.3.*
rm -f Tcl_GetVar2Ex.3 Tcl_GetVar2Ex.3.*
rm -f Tcl_GetVar.3 Tcl_GetVar.3.*
rm -f Tcl_GetVar2.3 Tcl_GetVar2.3.*
rm -f Tcl_ObjGetVar2.3 Tcl_ObjGetVar2.3.*
rm -f Tcl_UnsetVar.3 Tcl_UnsetVar.3.*
rm -f Tcl_UnsetVar2.3 Tcl_UnsetVar2.3.*
ln $S SetVar.3$Z Tcl_SetVar2Ex.3$Z
ln $S SetVar.3$Z Tcl_SetVar.3$Z
ln $S SetVar.3$Z Tcl_SetVar2.3$Z
ln $S SetVar.3$Z Tcl_ObjSetVar2.3$Z
ln $S SetVar.3$Z Tcl_GetVar2Ex.3$Z
ln $S SetVar.3$Z Tcl_GetVar.3$Z
ln $S SetVar.3$Z Tcl_GetVar2.3$Z
ln $S SetVar.3$Z Tcl_ObjGetVar2.3$Z
ln $S SetVar.3$Z Tcl_UnsetVar.3$Z
ln $S SetVar.3$Z Tcl_UnsetVar2.3$Z
fi
if test -r Signal.3; then
rm -f Signal.3.*
$ZIP Signal.3
rm -f Tcl_SignalId.3 Tcl_SignalId.3.*
rm -f Tcl_SignalMsg.3 Tcl_SignalMsg.3.*
ln $S Signal.3$Z Tcl_SignalId.3$Z
ln $S Signal.3$Z Tcl_SignalMsg.3$Z
fi
if test -r Sleep.3; then
rm -f Sleep.3.*
$ZIP Sleep.3
rm -f Tcl_Sleep.3 Tcl_Sleep.3.*
ln $S Sleep.3$Z Tcl_Sleep.3$Z
fi
if test -r SourceRCFile.3; then
rm -f SourceRCFile.3.*
$ZIP SourceRCFile.3
rm -f Tcl_SourceRCFile.3 Tcl_SourceRCFile.3.*
ln $S SourceRCFile.3$Z Tcl_SourceRCFile.3$Z
fi
if test -r SplitList.3; then
rm -f SplitList.3.*
$ZIP SplitList.3
rm -f Tcl_SplitList.3 Tcl_SplitList.3.*
rm -f Tcl_Merge.3 Tcl_Merge.3.*
rm -f Tcl_ScanElement.3 Tcl_ScanElement.3.*
rm -f Tcl_ConvertElement.3 Tcl_ConvertElement.3.*
rm -f Tcl_ScanCountedElement.3 Tcl_ScanCountedElement.3.*
rm -f Tcl_ConvertCountedElement.3 Tcl_ConvertCountedElement.3.*
ln $S SplitList.3$Z Tcl_SplitList.3$Z
ln $S SplitList.3$Z Tcl_Merge.3$Z
ln $S SplitList.3$Z Tcl_ScanElement.3$Z
ln $S SplitList.3$Z Tcl_ConvertElement.3$Z
ln $S SplitList.3$Z Tcl_ScanCountedElement.3$Z
ln $S SplitList.3$Z Tcl_ConvertCountedElement.3$Z
fi
if test -r SplitPath.3; then
rm -f SplitPath.3.*
$ZIP SplitPath.3
rm -f Tcl_SplitPath.3 Tcl_SplitPath.3.*
rm -f Tcl_JoinPath.3 Tcl_JoinPath.3.*
rm -f Tcl_GetPathType.3 Tcl_GetPathType.3.*
ln $S SplitPath.3$Z Tcl_SplitPath.3$Z
ln $S SplitPath.3$Z Tcl_JoinPath.3$Z
ln $S SplitPath.3$Z Tcl_GetPathType.3$Z
fi
if test -r StaticPkg.3; then
rm -f StaticPkg.3.*
$ZIP StaticPkg.3
rm -f Tcl_StaticPackage.3 Tcl_StaticPackage.3.*
ln $S StaticPkg.3$Z Tcl_StaticPackage.3$Z
fi
if test -r StdChannels.3; then
rm -f StdChannels.3.*
$ZIP StdChannels.3
rm -f Tcl_StandardChannels.3 Tcl_StandardChannels.3.*
ln $S StdChannels.3$Z Tcl_StandardChannels.3$Z
fi
if test -r StrMatch.3; then
rm -f StrMatch.3.*
$ZIP StrMatch.3
rm -f Tcl_StringMatch.3 Tcl_StringMatch.3.*
rm -f Tcl_StringCaseMatch.3 Tcl_StringCaseMatch.3.*
ln $S StrMatch.3$Z Tcl_StringMatch.3$Z
ln $S StrMatch.3$Z Tcl_StringCaseMatch.3$Z
fi
if test -r StringObj.3; then
rm -f StringObj.3.*
$ZIP StringObj.3
rm -f Tcl_NewStringObj.3 Tcl_NewStringObj.3.*
rm -f Tcl_NewUnicodeObj.3 Tcl_NewUnicodeObj.3.*
rm -f Tcl_SetStringObj.3 Tcl_SetStringObj.3.*
rm -f Tcl_SetUnicodeObj.3 Tcl_SetUnicodeObj.3.*
rm -f Tcl_GetStringFromObj.3 Tcl_GetStringFromObj.3.*
rm -f Tcl_GetString.3 Tcl_GetString.3.*
rm -f Tcl_GetUnicodeFromObj.3 Tcl_GetUnicodeFromObj.3.*
rm -f Tcl_GetUnicode.3 Tcl_GetUnicode.3.*
rm -f Tcl_GetUniChar.3 Tcl_GetUniChar.3.*
rm -f Tcl_GetCharLength.3 Tcl_GetCharLength.3.*
rm -f Tcl_GetRange.3 Tcl_GetRange.3.*
rm -f Tcl_AppendToObj.3 Tcl_AppendToObj.3.*
rm -f Tcl_AppendUnicodeToObj.3 Tcl_AppendUnicodeToObj.3.*
rm -f Tcl_AppendStringsToObj.3 Tcl_AppendStringsToObj.3.*
rm -f Tcl_AppendStringsToObjVA.3 Tcl_AppendStringsToObjVA.3.*
rm -f Tcl_AppendObjToObj.3 Tcl_AppendObjToObj.3.*
rm -f Tcl_SetObjLength.3 Tcl_SetObjLength.3.*
rm -f Tcl_ConcatObj.3 Tcl_ConcatObj.3.*
rm -f Tcl_AttemptSetObjLength.3 Tcl_AttemptSetObjLength.3.*
ln $S StringObj.3$Z Tcl_NewStringObj.3$Z
ln $S StringObj.3$Z Tcl_NewUnicodeObj.3$Z
ln $S StringObj.3$Z Tcl_SetStringObj.3$Z
ln $S StringObj.3$Z Tcl_SetUnicodeObj.3$Z
ln $S StringObj.3$Z Tcl_GetStringFromObj.3$Z
ln $S StringObj.3$Z Tcl_GetString.3$Z
ln $S StringObj.3$Z Tcl_GetUnicodeFromObj.3$Z
ln $S StringObj.3$Z Tcl_GetUnicode.3$Z
ln $S StringObj.3$Z Tcl_GetUniChar.3$Z
ln $S StringObj.3$Z Tcl_GetCharLength.3$Z
ln $S StringObj.3$Z Tcl_GetRange.3$Z
ln $S StringObj.3$Z Tcl_AppendToObj.3$Z
ln $S StringObj.3$Z Tcl_AppendUnicodeToObj.3$Z
ln $S StringObj.3$Z Tcl_AppendStringsToObj.3$Z
ln $S StringObj.3$Z Tcl_AppendStringsToObjVA.3$Z
ln $S StringObj.3$Z Tcl_AppendObjToObj.3$Z
ln $S StringObj.3$Z Tcl_SetObjLength.3$Z
ln $S StringObj.3$Z Tcl_ConcatObj.3$Z
ln $S StringObj.3$Z Tcl_AttemptSetObjLength.3$Z
fi
if test -r SubstObj.3; then
rm -f SubstObj.3.*
$ZIP SubstObj.3
rm -f Tcl_SubstObj.3 Tcl_SubstObj.3.*
ln $S SubstObj.3$Z Tcl_SubstObj.3$Z
fi
if test -r TCL_MEM_DEBUG.3; then
rm -f TCL_MEM_DEBUG.3.*
$ZIP TCL_MEM_DEBUG.3
fi
if test -r Tcl.n; then
rm -f Tcl.n.*
$ZIP Tcl.n
fi
if test -r Tcl_Main.3; then
rm -f Tcl_Main.3.*
$ZIP Tcl_Main.3
rm -f Tcl_SetMainLoop.3 Tcl_SetMainLoop.3.*
ln $S Tcl_Main.3$Z Tcl_SetMainLoop.3$Z
fi
if test -r Thread.3; then
rm -f Thread.3.*
$ZIP Thread.3
rm -f Tcl_ConditionNotify.3 Tcl_ConditionNotify.3.*
rm -f Tcl_ConditionWait.3 Tcl_ConditionWait.3.*
rm -f Tcl_ConditionFinalize.3 Tcl_ConditionFinalize.3.*
rm -f Tcl_GetThreadData.3 Tcl_GetThreadData.3.*
rm -f Tcl_MutexLock.3 Tcl_MutexLock.3.*
rm -f Tcl_MutexUnlock.3 Tcl_MutexUnlock.3.*
rm -f Tcl_MutexFinalize.3 Tcl_MutexFinalize.3.*
rm -f Tcl_CreateThread.3 Tcl_CreateThread.3.*
rm -f Tcl_JoinThread.3 Tcl_JoinThread.3.*
ln $S Thread.3$Z Tcl_ConditionNotify.3$Z
ln $S Thread.3$Z Tcl_ConditionWait.3$Z
ln $S Thread.3$Z Tcl_ConditionFinalize.3$Z
ln $S Thread.3$Z Tcl_GetThreadData.3$Z
ln $S Thread.3$Z Tcl_MutexLock.3$Z
ln $S Thread.3$Z Tcl_MutexUnlock.3$Z
ln $S Thread.3$Z Tcl_MutexFinalize.3$Z
ln $S Thread.3$Z Tcl_CreateThread.3$Z
ln $S Thread.3$Z Tcl_JoinThread.3$Z
fi
if test -r ToUpper.3; then
rm -f ToUpper.3.*
$ZIP ToUpper.3
rm -f Tcl_UniCharToUpper.3 Tcl_UniCharToUpper.3.*
rm -f Tcl_UniCharToLower.3 Tcl_UniCharToLower.3.*
rm -f Tcl_UniCharToTitle.3 Tcl_UniCharToTitle.3.*
rm -f Tcl_UtfToUpper.3 Tcl_UtfToUpper.3.*
rm -f Tcl_UtfToLower.3 Tcl_UtfToLower.3.*
rm -f Tcl_UtfToTitle.3 Tcl_UtfToTitle.3.*
ln $S ToUpper.3$Z Tcl_UniCharToUpper.3$Z
ln $S ToUpper.3$Z Tcl_UniCharToLower.3$Z
ln $S ToUpper.3$Z Tcl_UniCharToTitle.3$Z
ln $S ToUpper.3$Z Tcl_UtfToUpper.3$Z
ln $S ToUpper.3$Z Tcl_UtfToLower.3$Z
ln $S ToUpper.3$Z Tcl_UtfToTitle.3$Z
fi
if test -r TraceCmd.3; then
rm -f TraceCmd.3.*
$ZIP TraceCmd.3
rm -f Tcl_CommandTraceInfo.3 Tcl_CommandTraceInfo.3.*
rm -f Tcl_TraceCommand.3 Tcl_TraceCommand.3.*
rm -f Tcl_UntraceCommand.3 Tcl_UntraceCommand.3.*
ln $S TraceCmd.3$Z Tcl_CommandTraceInfo.3$Z
ln $S TraceCmd.3$Z Tcl_TraceCommand.3$Z
ln $S TraceCmd.3$Z Tcl_UntraceCommand.3$Z
fi
if test -r TraceVar.3; then
rm -f TraceVar.3.*
$ZIP TraceVar.3
rm -f Tcl_TraceVar.3 Tcl_TraceVar.3.*
rm -f Tcl_TraceVar2.3 Tcl_TraceVar2.3.*
rm -f Tcl_UntraceVar.3 Tcl_UntraceVar.3.*
rm -f Tcl_UntraceVar2.3 Tcl_UntraceVar2.3.*
rm -f Tcl_VarTraceInfo.3 Tcl_VarTraceInfo.3.*
rm -f Tcl_VarTraceInfo2.3 Tcl_VarTraceInfo2.3.*
ln $S TraceVar.3$Z Tcl_TraceVar.3$Z
ln $S TraceVar.3$Z Tcl_TraceVar2.3$Z
ln $S TraceVar.3$Z Tcl_UntraceVar.3$Z
ln $S TraceVar.3$Z Tcl_UntraceVar2.3$Z
ln $S TraceVar.3$Z Tcl_VarTraceInfo.3$Z
ln $S TraceVar.3$Z Tcl_VarTraceInfo2.3$Z
fi
if test -r Translate.3; then
rm -f Translate.3.*
$ZIP Translate.3
rm -f Tcl_TranslateFileName.3 Tcl_TranslateFileName.3.*
ln $S Translate.3$Z Tcl_TranslateFileName.3$Z
fi
if test -r UniCharIsAlpha.3; then
rm -f UniCharIsAlpha.3.*
$ZIP UniCharIsAlpha.3
rm -f Tcl_UniCharIsAlnum.3 Tcl_UniCharIsAlnum.3.*
rm -f Tcl_UniCharIsAlpha.3 Tcl_UniCharIsAlpha.3.*
rm -f Tcl_UniCharIsControl.3 Tcl_UniCharIsControl.3.*
rm -f Tcl_UniCharIsDigit.3 Tcl_UniCharIsDigit.3.*
rm -f Tcl_UniCharIsGraph.3 Tcl_UniCharIsGraph.3.*
rm -f Tcl_UniCharIsLower.3 Tcl_UniCharIsLower.3.*
rm -f Tcl_UniCharIsPrint.3 Tcl_UniCharIsPrint.3.*
rm -f Tcl_UniCharIsPunct.3 Tcl_UniCharIsPunct.3.*
rm -f Tcl_UniCharIsSpace.3 Tcl_UniCharIsSpace.3.*
rm -f Tcl_UniCharIsUpper.3 Tcl_UniCharIsUpper.3.*
rm -f Tcl_UniCharIsWordChar.3 Tcl_UniCharIsWordChar.3.*
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsAlnum.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsAlpha.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsControl.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsDigit.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsGraph.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsLower.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsPrint.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsPunct.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsSpace.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsUpper.3$Z
ln $S UniCharIsAlpha.3$Z Tcl_UniCharIsWordChar.3$Z
fi
if test -r UpVar.3; then
rm -f UpVar.3.*
$ZIP UpVar.3
rm -f Tcl_UpVar.3 Tcl_UpVar.3.*
rm -f Tcl_UpVar2.3 Tcl_UpVar2.3.*
ln $S UpVar.3$Z Tcl_UpVar.3$Z
ln $S UpVar.3$Z Tcl_UpVar2.3$Z
fi
if test -r Utf.3; then
rm -f Utf.3.*
$ZIP Utf.3
rm -f Tcl_UniChar.3 Tcl_UniChar.3.*
rm -f Tcl_UniCharCaseMatch.3 Tcl_UniCharCaseMatch.3.*
rm -f Tcl_UniCharNcasecmp.3 Tcl_UniCharNcasecmp.3.*
rm -f Tcl_UniCharToUtf.3 Tcl_UniCharToUtf.3.*
rm -f Tcl_UtfToUniChar.3 Tcl_UtfToUniChar.3.*
rm -f Tcl_UniCharToUtfDString.3 Tcl_UniCharToUtfDString.3.*
rm -f Tcl_UtfToUniCharDString.3 Tcl_UtfToUniCharDString.3.*
rm -f Tcl_UniCharLen.3 Tcl_UniCharLen.3.*
rm -f Tcl_UniCharNcmp.3 Tcl_UniCharNcmp.3.*
rm -f Tcl_UtfCharComplete.3 Tcl_UtfCharComplete.3.*
rm -f Tcl_NumUtfChars.3 Tcl_NumUtfChars.3.*
rm -f Tcl_UtfFindFirst.3 Tcl_UtfFindFirst.3.*
rm -f Tcl_UtfFindLast.3 Tcl_UtfFindLast.3.*
rm -f Tcl_UtfNext.3 Tcl_UtfNext.3.*
rm -f Tcl_UtfPrev.3 Tcl_UtfPrev.3.*
rm -f Tcl_UniCharAtIndex.3 Tcl_UniCharAtIndex.3.*
rm -f Tcl_UtfAtIndex.3 Tcl_UtfAtIndex.3.*
rm -f Tcl_UtfBackslash.3 Tcl_UtfBackslash.3.*
ln $S Utf.3$Z Tcl_UniChar.3$Z
ln $S Utf.3$Z Tcl_UniCharCaseMatch.3$Z
ln $S Utf.3$Z Tcl_UniCharNcasecmp.3$Z
ln $S Utf.3$Z Tcl_UniCharToUtf.3$Z
ln $S Utf.3$Z Tcl_UtfToUniChar.3$Z
ln $S Utf.3$Z Tcl_UniCharToUtfDString.3$Z
ln $S Utf.3$Z Tcl_UtfToUniCharDString.3$Z
ln $S Utf.3$Z Tcl_UniCharLen.3$Z
ln $S Utf.3$Z Tcl_UniCharNcmp.3$Z
ln $S Utf.3$Z Tcl_UtfCharComplete.3$Z
ln $S Utf.3$Z Tcl_NumUtfChars.3$Z
ln $S Utf.3$Z Tcl_UtfFindFirst.3$Z
ln $S Utf.3$Z Tcl_UtfFindLast.3$Z
ln $S Utf.3$Z Tcl_UtfNext.3$Z
ln $S Utf.3$Z Tcl_UtfPrev.3$Z
ln $S Utf.3$Z Tcl_UniCharAtIndex.3$Z
ln $S Utf.3$Z Tcl_UtfAtIndex.3$Z
ln $S Utf.3$Z Tcl_UtfBackslash.3$Z
fi
if test -r WrongNumArgs.3; then
rm -f WrongNumArgs.3.*
$ZIP WrongNumArgs.3
rm -f Tcl_WrongNumArgs.3 Tcl_WrongNumArgs.3.*
ln $S WrongNumArgs.3$Z Tcl_WrongNumArgs.3$Z
fi
if test -r after.n; then
rm -f after.n.*
$ZIP after.n
fi
if test -r append.n; then
rm -f append.n.*
$ZIP append.n
fi
if test -r array.n; then
rm -f array.n.*
$ZIP array.n
fi
if test -r bgerror.n; then
rm -f bgerror.n.*
$ZIP bgerror.n
fi
if test -r binary.n; then
rm -f binary.n.*
$ZIP binary.n
fi
if test -r break.n; then
rm -f break.n.*
$ZIP break.n
fi
if test -r case.n; then
rm -f case.n.*
$ZIP case.n
fi
if test -r catch.n; then
rm -f catch.n.*
$ZIP catch.n
fi
if test -r cd.n; then
rm -f cd.n.*
$ZIP cd.n
fi
if test -r clock.n; then
rm -f clock.n.*
$ZIP clock.n
fi
if test -r close.n; then
rm -f close.n.*
$ZIP close.n
fi
if test -r concat.n; then
rm -f concat.n.*
$ZIP concat.n
fi
if test -r continue.n; then
rm -f continue.n.*
$ZIP continue.n
fi
if test -r dde.n; then
rm -f dde.n.*
$ZIP dde.n
fi
if test -r encoding.n; then
rm -f encoding.n.*
$ZIP encoding.n
fi
if test -r eof.n; then
rm -f eof.n.*
$ZIP eof.n
fi
if test -r error.n; then
rm -f error.n.*
$ZIP error.n
fi
if test -r eval.n; then
rm -f eval.n.*
$ZIP eval.n
fi
if test -r exec.n; then
rm -f exec.n.*
$ZIP exec.n
fi
if test -r exit.n; then
rm -f exit.n.*
$ZIP exit.n
fi
if test -r expr.n; then
rm -f expr.n.*
$ZIP expr.n
fi
if test -r fblocked.n; then
rm -f fblocked.n.*
$ZIP fblocked.n
fi
if test -r fconfigure.n; then
rm -f fconfigure.n.*
$ZIP fconfigure.n
fi
if test -r fcopy.n; then
rm -f fcopy.n.*
$ZIP fcopy.n
fi
if test -r file.n; then
rm -f file.n.*
$ZIP file.n
fi
if test -r fileevent.n; then
rm -f fileevent.n.*
$ZIP fileevent.n
fi
if test -r filename.n; then
rm -f filename.n.*
$ZIP filename.n
fi
if test -r flush.n; then
rm -f flush.n.*
$ZIP flush.n
fi
if test -r for.n; then
rm -f for.n.*
$ZIP for.n
fi
if test -r foreach.n; then
rm -f foreach.n.*
$ZIP foreach.n
fi
if test -r format.n; then
rm -f format.n.*
$ZIP format.n
fi
if test -r gets.n; then
rm -f gets.n.*
$ZIP gets.n
fi
if test -r glob.n; then
rm -f glob.n.*
$ZIP glob.n
fi
if test -r global.n; then
rm -f global.n.*
$ZIP global.n
fi
if test -r history.n; then
rm -f history.n.*
$ZIP history.n
fi
if test -r http.n; then
rm -f http.n.*
$ZIP http.n
fi
if test -r if.n; then
rm -f if.n.*
$ZIP if.n
fi
if test -r incr.n; then
rm -f incr.n.*
$ZIP incr.n
fi
if test -r info.n; then
rm -f info.n.*
$ZIP info.n
fi
if test -r interp.n; then
rm -f interp.n.*
$ZIP interp.n
fi
if test -r join.n; then
rm -f join.n.*
$ZIP join.n
fi
if test -r lappend.n; then
rm -f lappend.n.*
$ZIP lappend.n
fi
if test -r library.n; then
rm -f library.n.*
$ZIP library.n
rm -f auto_execok.n auto_execok.n.*
rm -f auto_import.n auto_import.n.*
rm -f auto_load.n auto_load.n.*
rm -f auto_mkindex.n auto_mkindex.n.*
rm -f auto_mkindex_old.n auto_mkindex_old.n.*
rm -f auto_qualify.n auto_qualify.n.*
rm -f auto_reset.n auto_reset.n.*
rm -f tcl_findLibrary.n tcl_findLibrary.n.*
rm -f parray.n parray.n.*
rm -f tcl_endOfWord.n tcl_endOfWord.n.*
rm -f tcl_startOfNextWord.n tcl_startOfNextWord.n.*
rm -f tcl_startOfPreviousWord.n tcl_startOfPreviousWord.n.*
rm -f tcl_wordBreakAfter.n tcl_wordBreakAfter.n.*
rm -f tcl_wordBreakBefore.n tcl_wordBreakBefore.n.*
ln $S library.n$Z auto_execok.n$Z
ln $S library.n$Z auto_import.n$Z
ln $S library.n$Z auto_load.n$Z
ln $S library.n$Z auto_mkindex.n$Z
ln $S library.n$Z auto_mkindex_old.n$Z
ln $S library.n$Z auto_qualify.n$Z
ln $S library.n$Z auto_reset.n$Z
ln $S library.n$Z tcl_findLibrary.n$Z
ln $S library.n$Z parray.n$Z
ln $S library.n$Z tcl_endOfWord.n$Z
ln $S library.n$Z tcl_startOfNextWord.n$Z
ln $S library.n$Z tcl_startOfPreviousWord.n$Z
ln $S library.n$Z tcl_wordBreakAfter.n$Z
ln $S library.n$Z tcl_wordBreakBefore.n$Z
fi
if test -r lindex.n; then
rm -f lindex.n.*
$ZIP lindex.n
fi
if test -r linsert.n; then
rm -f linsert.n.*
$ZIP linsert.n
fi
if test -r list.n; then
rm -f list.n.*
$ZIP list.n
fi
if test -r llength.n; then
rm -f llength.n.*
$ZIP llength.n
fi
if test -r load.n; then
rm -f load.n.*
$ZIP load.n
fi
if test -r lrange.n; then
rm -f lrange.n.*
$ZIP lrange.n
fi
if test -r lreplace.n; then
rm -f lreplace.n.*
$ZIP lreplace.n
fi
if test -r lsearch.n; then
rm -f lsearch.n.*
$ZIP lsearch.n
fi
if test -r lset.n; then
rm -f lset.n.*
$ZIP lset.n
fi
if test -r lsort.n; then
rm -f lsort.n.*
$ZIP lsort.n
fi
if test -r memory.n; then
rm -f memory.n.*
$ZIP memory.n
fi
if test -r msgcat.n; then
rm -f msgcat.n.*
$ZIP msgcat.n
fi
if test -r namespace.n; then
rm -f namespace.n.*
$ZIP namespace.n
fi
if test -r open.n; then
rm -f open.n.*
$ZIP open.n
fi
if test -r package.n; then
rm -f package.n.*
$ZIP package.n
fi
if test -r packagens.n; then
rm -f packagens.n.*
$ZIP packagens.n
rm -f pkg::create.n pkg::create.n.*
ln $S packagens.n$Z pkg::create.n$Z
fi
if test -r pid.n; then
rm -f pid.n.*
$ZIP pid.n
fi
if test -r pkgMkIndex.n; then
rm -f pkgMkIndex.n.*
$ZIP pkgMkIndex.n
rm -f pkg_mkIndex.n pkg_mkIndex.n.*
ln $S pkgMkIndex.n$Z pkg_mkIndex.n$Z
fi
if test -r proc.n; then
rm -f proc.n.*
$ZIP proc.n
fi
if test -r puts.n; then
rm -f puts.n.*
$ZIP puts.n
fi
if test -r pwd.n; then
rm -f pwd.n.*
$ZIP pwd.n
fi
if test -r re_syntax.n; then
rm -f re_syntax.n.*
$ZIP re_syntax.n
fi
if test -r read.n; then
rm -f read.n.*
$ZIP read.n
fi
if test -r regexp.n; then
rm -f regexp.n.*
$ZIP regexp.n
fi
if test -r registry.n; then
rm -f registry.n.*
$ZIP registry.n
fi
if test -r regsub.n; then
rm -f regsub.n.*
$ZIP regsub.n
fi
if test -r rename.n; then
rm -f rename.n.*
$ZIP rename.n
fi
if test -r resource.n; then
rm -f resource.n.*
$ZIP resource.n
fi
if test -r return.n; then
rm -f return.n.*
$ZIP return.n
fi
if test -r safe.n; then
rm -f safe.n.*
$ZIP safe.n
rm -f SafeBase.n SafeBase.n.*
ln $S safe.n$Z SafeBase.n$Z
fi
if test -r scan.n; then
rm -f scan.n.*
$ZIP scan.n
fi
if test -r seek.n; then
rm -f seek.n.*
$ZIP seek.n
fi
if test -r set.n; then
rm -f set.n.*
$ZIP set.n
fi
if test -r socket.n; then
rm -f socket.n.*
$ZIP socket.n
fi
if test -r source.n; then
rm -f source.n.*
$ZIP source.n
fi
if test -r split.n; then
rm -f split.n.*
$ZIP split.n
fi
if test -r string.n; then
rm -f string.n.*
$ZIP string.n
fi
if test -r subst.n; then
rm -f subst.n.*
$ZIP subst.n
fi
if test -r switch.n; then
rm -f switch.n.*
$ZIP switch.n
fi
if test -r tclsh.1; then
rm -f tclsh.1.*
$ZIP tclsh.1
fi
if test -r tcltest.n; then
rm -f tcltest.n.*
$ZIP tcltest.n
fi
if test -r tclvars.n; then
rm -f tclvars.n.*
$ZIP tclvars.n
fi
if test -r tell.n; then
rm -f tell.n.*
$ZIP tell.n
fi
if test -r time.n; then
rm -f time.n.*
$ZIP time.n
fi
if test -r trace.n; then
rm -f trace.n.*
$ZIP trace.n
fi
if test -r unknown.n; then
rm -f unknown.n.*
$ZIP unknown.n
fi
if test -r unset.n; then
rm -f unset.n.*
$ZIP unset.n
fi
if test -r update.n; then
rm -f update.n.*
$ZIP update.n
fi
if test -r uplevel.n; then
rm -f uplevel.n.*
$ZIP uplevel.n
fi
if test -r upvar.n; then
rm -f upvar.n.*
$ZIP upvar.n
fi
if test -r variable.n; then
rm -f variable.n.*
$ZIP variable.n
fi
if test -r vwait.n; then
rm -f vwait.n.*
$ZIP vwait.n
fi
if test -r while.n; then
rm -f while.n.*
$ZIP while.n
fi
exit 0
|
Changes to unix/mkLinks.tcl.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 | # Because of the length of command and procedure names, this mechanism # only works on machines that support file names longer than 14 characters. # This script checks to see if long file names are supported, and it # doesn't make any links if they are not. # # The script takes one argument, which is the name of the directory # where the manual entries have been installed. if test $# != 1; then | > > > > > > > > > > > > > > > > | > > > > > > > | 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 |
# Because of the length of command and procedure names, this mechanism
# only works on machines that support file names longer than 14 characters.
# This script checks to see if long file names are supported, and it
# doesn't make any links if they are not.
#
# The script takes one argument, which is the name of the directory
# where the manual entries have been installed.
ZIP=true
while true; do
case $1 in
-s | --symlinks )
S=-s
;;
-z | --compress )
ZIP=$2
shift
;;
*) break
;;
esac
shift
done
if test $# != 1; then
echo "Usage: mkLinks <options> dir"
exit 1
fi
if test "x$ZIP" != "xtrue"; then
touch TeST
$ZIP TeST
Z=`ls TeST* | sed 's/^[^.]*//'`
rm -f TeST*
fi
cd $1
echo foo > xyzzyTestingAVeryLongFileName.foo
x=`echo xyzzyTe*`
echo foo > xyzzyTestingaverylongfilename.foo
y=`echo xyzzyTestingav*`
rm xyzzyTe*
|
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
set tst $case_insensitive_test
set tstfi $case_insensitive_test_fi
} else {
set tst ""
set tstfi ""
}
lappend namelist $name$ext
| | | < | > > > < > | 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 |
set tst $case_insensitive_test
set tstfi $case_insensitive_test_fi
} else {
set tst ""
set tstfi ""
}
lappend namelist $name$ext
append rmOutput " $tst rm -f $name$ext $name$ext.* $tstfi\n"
append lnOutput " $tst ln \$S $tail\$Z $name$ext\$Z $tstfi\n"
}
}
puts "if test -r $tail; then"
puts " rm -f $tail.*"
puts " \$ZIP $tail"
if { [llength $namelist] } {
puts -nonewline $rmOutput
puts -nonewline $lnOutput
}
puts "fi"
set state end
}
end {
break
}
}
}
close $in
}
puts "exit 0"
|
Changes to unix/tcl.m4.
| ︙ | ︙ | |||
54 55 56 57 58 59 60 |
break
fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tclconfig}" = x ; then
| | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
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
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
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
| | | 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
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
|
| ︙ | ︙ | |||
349 350 351 352 353 354 355 |
# Sets the following vars:
# FRAMEWORK_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN(SC_ENABLE_FRAMEWORK, [
AC_MSG_CHECKING([how to package libraries])
AC_ARG_ENABLE(framework,
| | > > | | > | < < | 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 |
# Sets the following vars:
# FRAMEWORK_BUILD Value of 1 or 0
#------------------------------------------------------------------------
AC_DEFUN(SC_ENABLE_FRAMEWORK, [
AC_MSG_CHECKING([how to package libraries])
AC_ARG_ENABLE(framework,
[ --enable-framework package shared libraries in frameworks [--disable-framework]],
[tcl_ok=$enableval], [tcl_ok=no])
if test "${enable_framework+set}" = set; then
enableval="$enable_framework"
tcl_ok=$enableval
else
tcl_ok=no
fi
if test "$tcl_ok" = "yes" ; then
AC_MSG_RESULT([framework])
FRAMEWORK_BUILD=1
if test "${SHARED_BUILD}" = "0" ; then
AC_MSG_WARN("Frameworks can only be built if --enable-shared is yes")
FRAMEWORK_BUILD=0
fi
else
AC_MSG_RESULT([standard shared library])
FRAMEWORK_BUILD=0
fi
])
#------------------------------------------------------------------------
|
| ︙ | ︙ | |||
496 497 498 499 500 501 502 503 504 505 506 507 508 509 |
AC_MSG_RESULT([yes])
else
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
DBGX=""
AC_MSG_RESULT([no])
fi
])
#------------------------------------------------------------------------
# SC_ENABLE_LANGINFO --
#
# Allows use of modern nl_langinfo check for better l10n.
# This is only relevant for Unix.
| > > | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 |
AC_MSG_RESULT([yes])
else
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
DBGX=""
AC_MSG_RESULT([no])
fi
AC_SUBST(CFLAGS_DEFAULT)
AC_SUBST(LDFLAGS_DEFAULT)
])
#------------------------------------------------------------------------
# SC_ENABLE_LANGINFO --
#
# Allows use of modern nl_langinfo check for better l10n.
# This is only relevant for Unix.
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
fi
if test "$langinfo_ok" = "yes"; then
AC_DEFINE(HAVE_LANGINFO)
fi
fi
AC_MSG_RESULT([$langinfo_ok])
])
#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
# Try to determine the proper flags to pass to the compiler
# for building shared libraries and other such nonsense.
#
# Arguments:
# none
#
# Results:
#
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | | > > > | > > > > > < < | | | < < < < | 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 |
fi
if test "$langinfo_ok" = "yes"; then
AC_DEFINE(HAVE_LANGINFO)
fi
fi
AC_MSG_RESULT([$langinfo_ok])
])
#--------------------------------------------------------------------
# SC_CONFIG_MANPAGES
#
# Decide whether to use symlinks for linking the manpages and
# whether to compress the manpages after installation.
#
# Arguments:
# none
#
# Results:
#
# Adds the following arguments to configure:
# --enable-man-symlinks
# --enable-man-compression=PROG
#
# Defines the following variable:
#
# MKLINKS_FLAGS - The apropriate flags for mkLinks
# 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" && MKLINKS_FLAGS="$MKLINKS_FLAGS --symlinks",
enableval="no")
AC_MSG_RESULT([$enableval])
AC_MSG_CHECKING([compression for manpages])
AC_ARG_ENABLE(man-compression,
[ --enable-man-compression=PROG
compress the manpages with PROG],
test "$enableval" = "yes" && echo && AC_MSG_ERROR([missing argument to --enable-man-compression])
test "$enableval" != "no" && MKLINKS_FLAGS="$MKLINKS_FLAGS --compress $enableval",
enableval="no")
AC_MSG_RESULT([$enableval])
AC_SUBST(MKLINKS_FLAGS)
])
#--------------------------------------------------------------------
# SC_CONFIG_CFLAGS
#
# Try to determine the proper flags to pass to the compiler
# for building shared libraries and other such nonsense.
#
# Arguments:
# none
#
# Results:
#
# Defines and substitutes the following vars:
#
# DL_OBJS - Name of the object file that implements dynamic
# loading for Tcl on this system.
# DL_LIBS - Library file(s) to include in tclsh and other base
# applications in order for the "load" command to work.
# LDFLAGS - Flags to pass to the compiler when linking object
# files into an executable application binary such
# as tclsh.
# LD_SEARCH_FLAGS-Flags to pass to ld, such as "-R /usr/local/tcl/lib",
# that tell the run-time dynamic linker where to look
# for shared libraries such as libtcl.so. Depends on
# the variable LIB_RUNTIME_DIR in the Makefile. Could
# be the same as CC_SEARCH_FLAGS if ${CC} is used to link.
# CC_SEARCH_FLAGS-Flags to pass to ${CC}, such as "-Wl,-rpath,/usr/local/tcl/lib",
# that tell the run-time dynamic linker where to look
# for shared libraries such as libtcl.so. Depends on
# the variable LIB_RUNTIME_DIR in the Makefile.
# MAKE_LIB - Command to execute to build the a library;
# differs when building shared or static.
# MAKE_STUB_LIB -
# Command to execute to build a stub library.
# INSTALL_LIB - Command to execute to install a library;
# differs when building shared or static.
# INSTALL_STUB_LIB -
# Command to execute to install a stub library.
# 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_FLAGS -Flags to pass when building a shared library. This
# differes from the SHLIB_CFLAGS as it is not used
# when building object files or executables.
# 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
# SunOS 4.x, where they cause the link to fail, or in
# general if Tcl and Tk aren't themselves shared
# libraries), then this symbol has an empty string
# as its value.
# SHLIB_SUFFIX - Suffix to use for the names of dynamically loadable
# extensions. An empty string means we don't know how
# to use shared libraries on this platform.
# TCL_SHLIB_LD_EXTRAS - Additional element which are added to SHLIB_LD_LIBS
# for the build of TCL, but not recorded in the
# tclConfig.sh, since they are only used for the build
# of Tcl.
# Examples: MacOS X records the library version and
# compatibility version in the shared library. But
# of course the Tcl version of this is only used for Tcl.
# LIB_SUFFIX - Specifies everything that comes after the "libfoo"
# in a static or shared library name, using the $VERSION variable
# to put the version in the right place. This is used
# by platforms that need non-standard library names.
# Examples: ${VERSION}.so.1.1 on NetBSD, since it needs
# to have a version after the .so, and ${VERSION}.a
# on AIX, since a shared library needs to have
# a .a extension whereas shared objects for loadable
# extensions have a .so extension. Defaults to
# ${VERSION}${SHLIB_SUFFIX}.
# TCL_NEEDS_EXP_FILE -
# 1 means that an export file is needed to link to a
# shared library.
# TCL_EXP_FILE - The name of the installed export / import file which
# should be used to link to the Tcl shared library.
# Empty if Tcl is unshared.
# TCL_BUILD_EXP_FILE -
# 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
# EXTRA_CFLAGS
#
#--------------------------------------------------------------------
AC_DEFUN(SC_CONFIG_CFLAGS, [
# Step 0.a: Enable 64 bit support?
AC_MSG_CHECKING([if 64bit support is requested])
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 746 |
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# AIX-5 has dl* in libc.so
DL_LIBS=""
LDFLAGS=""
if test "$GCC" = "yes" ; then
| > | | > | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 |
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# AIX-5 has dl* in libc.so
DL_LIBS=""
LDFLAGS=""
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}'
# 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 with GCC on $system")
else
do64bit_ok=yes
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 |
SHLIB_CFLAGS=""
SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
| | > | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 |
SHLIB_CFLAGS=""
SHLIB_LD="${TCL_SRC_DIR}/unix/ldAix /bin/ld -bhalt:4 -bM:SRE -bE:lib.exp -H512 -T512 -bnoentry"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
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'
# 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"
|
| ︙ | ︙ | |||
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 |
SHLIB_CFLAGS=""
SHLIB_LD="shlicc -r"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
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="-export-dynamic"
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"
LDFLAGS=""
LD_SEARCH_FLAGS=""
;;
HP-UX-*.11.*)
# Use updated header definitions where possible
AC_DEFINE(_XOPEN_SOURCE_EXTENDED)
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='${LIBS}'
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="-Wl,-E"
| > > > | > | 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 |
SHLIB_CFLAGS=""
SHLIB_LD="shlicc -r"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
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="-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"
LDFLAGS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
HP-UX-*.11.*)
# Use updated header definitions where possible
AC_DEFINE(_XOPEN_SOURCE_EXTENDED)
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='${LIBS}'
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="-Wl,-E"
CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
fi
# 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 with GCC on $system")
else
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 | if test "$tcl_ok" = yes; then SHLIB_CFLAGS="+z" SHLIB_LD="ld -b" SHLIB_LD_LIBS="" DL_OBJS="tclLoadShl.o" DL_LIBS="-ldld" LDFLAGS="-Wl,-E" | | > | > | > | > | 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 |
if test "$tcl_ok" = yes; then
SHLIB_CFLAGS="+z"
SHLIB_LD="ld -b"
SHLIB_LD_LIBS=""
DL_OBJS="tclLoadShl.o"
DL_LIBS="-ldld"
LDFLAGS="-Wl,-E"
CC_SEARCH_FLAGS='-Wl,+s,+b,${LIB_RUNTIME_DIR}:.'
LD_SEARCH_FLAGS='+s +b ${LIB_RUNTIME_DIR}:.'
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="-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}'
EXTRA_CFLAGS=""
LDFLAGS=""
;;
IRIX-6.*|IRIX64-6.5*)
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
EXTRA_CFLAGS="-mabi=n32"
LDFLAGS="-mabi=n32"
else
case $system in
IRIX-6.3)
# Use to build 6.2 compatible binaries on 6.3.
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
| | > > > > > > > > > > > > > > > | > > | 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 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
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"
EXTRA_CFLAGS="-64"
LDFLAGS="-64"
fi
fi
;;
Linux*)
SHLIB_CFLAGS="-fPIC"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".so"
# 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"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="-rdynamic"
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"
LDFLAGS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""])
fi
if test "`uname -m`" = "alpha" ; then
EXTRA_CFLAGS="-mieee"
fi
# The combo of gcc + glibc has a bug related
|
| ︙ | ︙ | |||
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 |
SHLIB_SUFFIX=".so"
if test "$have_dl" = yes; then
SHLIB_LD="${CC} -shared"
DL_OBJS=""
DL_LIBS="-ldl"
LDFLAGS="-rdynamic"
LD_SEARCH_FLAGS=""
else
AC_CHECK_HEADER(dld.h, [
SHLIB_LD="ld -shared"
DL_OBJS=""
DL_LIBS="-ldld"
LDFLAGS=""
LD_SEARCH_FLAGS=""])
fi
if test "`uname -m`" = "alpha" ; then
EXTRA_CFLAGS="-mieee"
fi
;;
MP-RAS-02*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
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="-Wl,-Bexport"
LD_SEARCH_FLAGS=""
;;
NetBSD-*|FreeBSD-[[1-2]].*|OpenBSD-*)
# 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=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
| > > > > | > | > | > < < < | | | | > > > < > > > | > | 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 |
SHLIB_SUFFIX=".so"
if test "$have_dl" = yes; then
SHLIB_LD="${CC} -shared"
DL_OBJS=""
DL_LIBS="-ldl"
LDFLAGS="-rdynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
else
AC_CHECK_HEADER(dld.h, [
SHLIB_LD="ld -shared"
DL_OBJS=""
DL_LIBS="-ldld"
LDFLAGS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""])
fi
if test "`uname -m`" = "alpha" ; then
EXTRA_CFLAGS="-mieee"
fi
;;
MP-RAS-02*)
SHLIB_CFLAGS="-K PIC"
SHLIB_LD="cc -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS=""
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="-Wl,-Bexport"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
NetBSD-*|FreeBSD-[[1-2]].*|OpenBSD-*)
# 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=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
AC_MSG_CHECKING(for ELF)
AC_EGREP_CPP(yes, [
#ifdef __ELF__
yes
#endif
],
AC_MSG_RESULT(yes)
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so',
AC_MSG_RESULT(no)
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}\$\{DBGX\}.so.1.0'
)
], [
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'
])
# FreeBSD doesn't handle 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="-export-dynamic"
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
if test "${TCL_THREADS}" = "1" ; then
EXTRA_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
;;
Rhapsody-*|Darwin-*)
SHLIB_CFLAGS="-fno-common"
SHLIB_LD="cc -dynamiclib \${LDFLAGS}"
TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version \${VERSION} -install_name \${LIB_RUNTIME_DIR}/\${TCL_LIB_FILE} -prebind -seg1addr 0xa000000"
SHLIB_LD_LIBS='${LIBS}'
SHLIB_SUFFIX=".dylib"
DL_OBJS="tclLoadDyld.o"
PLAT_OBJS="tclMacOSXBundle.o"
DL_LIBS=""
LDFLAGS="-prebind"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
CFLAGS_OPTIMIZE="-Os"
LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
HACK=""
EXTRA_CFLAGS="-DMA${HACK}C_OSX_TCL -DHAVE_CFBUNDLE -DTCL_DEFAULT_ENCODING=\\\"utf-8\\\""
LIBS="$LIBS -framework CoreFoundation"
;;
NEXTSTEP-*)
SHLIB_CFLAGS=""
SHLIB_LD="cc -nostdlib -r"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadNext.o"
DL_LIBS=""
LDFLAGS=""
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=""
LDFLAGS=""
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=""
LDFLAGS=""
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=""
LDFLAGS=""
CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
if test "$GCC" != "yes" ; then
EXTRA_CFLAGS="-DHAVE_TZSET -std1"
fi
# see pthread_intro(3) for pthread support on osf1, k.furukawa
if test "${TCL_THREADS}" = "1" ; then
EXTRA_CFLAGS="${EXTRA_CFLAGS} -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
EXTRA_CFLAGS="${EXTRA_CFLAGS} -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
|
| ︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 |
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# dlopen is in -lc on QNX
DL_LIBS=""
LDFLAGS=""
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="-Wl,-D,08000000"
| > | > > > | > < > | > > | > < | 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 |
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# dlopen is in -lc on QNX
DL_LIBS=""
LDFLAGS=""
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="-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="-melf -Wl,-Bexport"
else
SHLIB_CFLAGS="-Kpic -belf"
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"
LDFLAGS=""
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"
LDFLAGS=""
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]]*)
# 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"
LDFLAGS=""
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"
LDFLAGS=""
# 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
|
| ︙ | ︙ | |||
1311 1312 1313 1314 1315 1316 1317 |
# 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
| > | > > > | > | 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 |
# 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='-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="-Wl,-D,08000000"
CC_SEARCH_FLAGS='-L${LIB_RUNTIME_DIR}'
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
if test "$GCC" != "yes" ; then
EXTRA_CFLAGS="-DHAVE_TZSET -std1"
fi
;;
UNIX_SV* | UnixWare-5*)
SHLIB_CFLAGS="-KPIC"
SHLIB_LD="cc -G"
|
| ︙ | ︙ | |||
1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 |
LDFLAGS=$hold_ldflags
AC_MSG_RESULT($found)
if test $found = yes; then
LDFLAGS="-Wl,-Bexport"
else
LDFLAGS=""
fi
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
| > | 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 |
LDFLAGS=$hold_ldflags
AC_MSG_RESULT($found)
if test $found = yes; then
LDFLAGS="-Wl,-Bexport"
else
LDFLAGS=""
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
|
| ︙ | ︙ | |||
1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 |
echo "on this system."
SHLIB_CFLAGS=""
SHLIB_LD=""
SHLIB_SUFFIX=""
DL_OBJS="tclLoadNone.o"
DL_LIBS=""
LDFLAGS=""
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.
| > | 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 |
echo "on this system."
SHLIB_CFLAGS=""
SHLIB_LD=""
SHLIB_SUFFIX=""
DL_OBJS="tclLoadNone.o"
DL_LIBS=""
LDFLAGS=""
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.
|
| ︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 |
if test "$SHARED_LIB_SUFFIX" = "" ; then
SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
fi
if test "$UNSHARED_LIB_SUFFIX" = "" ; then
UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
fi
AC_SUBST(DL_LIBS)
AC_SUBST(CFLAGS_DEBUG)
AC_SUBST(CFLAGS_OPTIMIZE)
AC_SUBST(CFLAGS_WARNING)
])
#--------------------------------------------------------------------
# SC_SERIAL_PORT
#
# Determine which interface to use to talk to the serial port.
# Note that #include lines must begin in leftmost column for
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
if test "$SHARED_LIB_SUFFIX" = "" ; then
SHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}${SHLIB_SUFFIX}'
fi
if test "$UNSHARED_LIB_SUFFIX" = "" ; then
UNSHARED_LIB_SUFFIX='${VERSION}\$\{DBGX\}.a'
fi
AC_REQUIRE([AC_PROG_RANLIB])
if test "${SHARED_BUILD}" = "1" && test "${SHLIB_SUFFIX}" != "" ; then
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
MAKE_LIB='${SHLIB_LD} -o [$]@ ${SHLIB_LD_FLAGS} ${OBJS} ${SHLIB_LD_LIBS} ${TCL_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)'
else
MAKE_LIB='${STLIB_LD} [$]@ ${OBJS} ; ${RANLIB} [$]@'
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) $(LIB_INSTALL_DIR)/$(LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(LIB_FILE))'
fi
dnl Not at all clear what this was doing in Tcl's configure.in
dnl or why it was needed was needed. In any event, this sort of
dnl things needs to be done in the big loop above.
dnl REMOVE THIS BLOCK LATER! (mdejong)
dnl case $system in
dnl BSD/OS*)
dnl ;;
dnl AIX-[[1-4]].*)
dnl ;;
dnl *)
dnl SHLIB_LD_LIBS=""
dnl ;;
dnl esac
fi
# Stub lib does not depend on shared/static configuration
if test "$RANLIB" = "" ; then
MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS}'
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE)'
else
MAKE_STUB_LIB='${STLIB_LD} [$]@ ${STUB_LIB_OBJS} ; ${RANLIB} [$]@'
INSTALL_STUB_LIB='$(INSTALL_LIBRARY) $(STUB_LIB_FILE) $(LIB_INSTALL_DIR)/$(STUB_LIB_FILE) ; (cd $(LIB_INSTALL_DIR) ; $(RANLIB) $(STUB_LIB_FILE))'
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)
AC_SUBST(EXTRA_CFLAGS)
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(SHLIB_LD_FLAGS)
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)
AC_SUBST(INSTALL_STUB_LIB)
AC_SUBST(RANLIB)
])
#--------------------------------------------------------------------
# SC_SERIAL_PORT
#
# Determine which interface to use to talk to the serial port.
# Note that #include lines must begin in leftmost column for
|
| ︙ | ︙ | |||
1563 1564 1565 1566 1567 1568 1569 |
struct sgttyb t;
if (ioctl(0, TIOCGETP, &t) == 0) {
t.sg_ospeed = 0;
t.sg_flags |= ODDP | EVENP | RAW;
return 0;
}
return 1;
| | | 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 |
struct sgttyb t;
if (ioctl(0, TIOCGETP, &t) == 0) {
t.sg_ospeed = 0;
t.sg_flags |= ODDP | EVENP | RAW;
return 0;
}
return 1;
}], tcl_cv_api_serial=sgtty, tcl_cv_api_serial=no, tcl_cv_api_serial=no)
fi
if test $tcl_cv_api_serial = no ; then
AC_TRY_RUN([
#include <termios.h>
#include <errno.h>
int main() {
|
| ︙ | ︙ | |||
1745 1746 1747 1748 1749 1750 1751 |
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)
| | | | > | | < | < | 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 |
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
|
| ︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 |
#
#--------------------------------------------------------------------
AC_DEFUN(SC_BUGGY_STRTOD, [
AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0)
if test "$tcl_strtod" = 1; then
AC_MSG_CHECKING([for Solaris2.4/Tru64 strtod bugs])
| > | | | < | | | | | | | > > > > | | | | | | | | 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 |
#
#--------------------------------------------------------------------
AC_DEFUN(SC_BUGGY_STRTOD, [
AC_CHECK_FUNC(strtod, tcl_strtod=1, tcl_strtod=0)
if test "$tcl_strtod" = 1; then
AC_MSG_CHECKING([for Solaris2.4/Tru64 strtod bugs])
AC_CACHE_VAL(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=1, tcl_cv_strtod_buggy=0, tcl_cv_strtod_buggy=0)])
if test "$tcl_cv_strtod_buggy" = 1; then
AC_MSG_RESULT(ok)
else
AC_MSG_RESULT(buggy)
LIBOBJS="$LIBOBJS fixstrtod.o"
AC_DEFINE(strtod, fixstrtod)
fi
fi
|
| ︙ | ︙ |
Changes to unix/tcl.spec.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 |
# $Id: tcl.spec,v 1.8.8.2 2002/08/20 20:25:30 das Exp $
# This file is the basis for a binary Tcl RPM for Linux.
%define version 8.4b3
%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.15.12.2 2002/08/20 20:25:30 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@' |
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | # an executable tclsh or tcltest binary. TCL_LD_FLAGS='@LDFLAGS@' # Flags to pass to ld, such as "-R /usr/local/tcl/lib", that tell the # run-time dynamic linker where to look for shared libraries such as # libtcl.so. Used when linking applications. Only works if there # is a variable "LIB_RUNTIME_DIR" defined in the Makefile. | > | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | # an executable tclsh or tcltest binary. TCL_LD_FLAGS='@LDFLAGS@' # Flags to pass to ld, such as "-R /usr/local/tcl/lib", that tell the # run-time dynamic linker where to look for shared libraries such as # libtcl.so. Used when linking applications. Only works if there # is a variable "LIB_RUNTIME_DIR" defined in the Makefile. TCL_CC_SEARCH_FLAGS='@CC_SEARCH_FLAGS@' TCL_LD_SEARCH_FLAGS='@LD_SEARCH_FLAGS@' # Additional object files linked with Tcl to provide compatibility # with standard facilities from ANSI C or POSIX. TCL_COMPAT_OBJS='@LIBOBJS@' # Name of the ranlib program to use. TCL_RANLIB='@RANLIB@' |
| ︙ | ︙ |
Changes to unix/tclLoadAout.c.
| ︙ | ︙ | |||
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. * * This work was supported in part by the ARPA Manufacturing Automation * and Design Engineering (MADE) Initiative through ARPA contract * F33615-94-C-4400. * | | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * This work was supported in part by the ARPA Manufacturing Automation * and Design Engineering (MADE) Initiative through ARPA contract * F33615-94-C-4400. * * RCS: @(#) $Id: tclLoadAout.c,v 1.7.2.3 2002/08/20 20:25:30 das Exp $ */ #include "tclInt.h" #include <fcntl.h> #ifdef HAVE_EXEC_AOUT_H # include <sys/exec_aout.h> #endif |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, Tcl_DString * buf)); static void UnlinkSymbolTable _ANSI_ARGS_((void)); /* *---------------------------------------------------------------------- * | | < | | < < | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | static int FindLibraries _ANSI_ARGS_((Tcl_Interp * interp, char * fileName, Tcl_DString * buf)); static void UnlinkSymbolTable _ANSI_ARGS_((void)); /* *---------------------------------------------------------------------- * * 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 interp's result. * * Side effects: * New code suddenly appears in memory. * * * Bugs: * This function does not attempt to handle the case where the |
| ︙ | ︙ | |||
137 138 139 140 141 142 143 | * fail with an `inconsistent memory allocation' error. * It perhaps ought to retry the link, but the failure has * not been observed in two years of daily use of this function. *---------------------------------------------------------------------- */ int | < | < < < < < | < < < | 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 |
* fail with an `inconsistent memory allocation' error.
* It perhaps ought to retry the link, but the failure has
* not been observed in two years of daily use of this function.
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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. */
{
char * inputSymbolTable; /* Name of the file containing the
* symbol table from the last link. */
Tcl_DString linkCommandBuf; /* Command to do the run-time relocation
* of the module.*/
char * linkCommand;
char relocatedFileName [L_tmpnam];
/* Name of the file holding the relocated */
/* text of the module */
int relocatedFd; /* File descriptor of the file holding
* relocated text */
struct exec relocatedHead; /* Header of the relocated text */
unsigned long relocatedSize; /* Size of the relocated text */
char * startAddress; /* Starting address of the module */
int status; /* Status return from Tcl_ calls */
char * p;
/* Find the file that contains the symbols for the run-time link. */
if (SymbolTableFile != NULL) {
inputSymbolTable = SymbolTableFile;
} else if (tclExecutableName == NULL) {
Tcl_SetResult (interp, "can't find the tclsh executable", TCL_STATIC);
return TCL_ERROR;
|
| ︙ | ︙ | |||
313 314 315 316 317 318 319 |
UnlinkSymbolTable ();
} else {
atexit (UnlinkSymbolTable);
}
SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1);
strcpy (SymbolTableFile, relocatedFileName);
| > > > | > > | > > > > > > > > > > > > > > > > > > > | | < | < | | 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 |
UnlinkSymbolTable ();
} else {
atexit (UnlinkSymbolTable);
}
SymbolTableFile = ckalloc (strlen (relocatedFileName) + 1);
strcpy (SymbolTableFile, relocatedFileName);
*loadHandle = startAddress;
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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
/* Look up the entry point in the load module's dictionary. */
DictFn dictionary = (DictFn) loadHandle;
return (Tcl_PackageInitProc*) dictionary(sym1);
}
/*
*------------------------------------------------------------------------
*
* FindLibraries --
*
* Find the libraries needed to link a load module at run time.
|
| ︙ | ︙ | |||
447 448 449 450 451 452 453 | * Side effects: * Does nothing. Can anything be done? * *---------------------------------------------------------------------- */ void | | | | | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 |
* Side effects:
* Does nothing. Can anything be done?
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
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.7.2.2 2002/08/20 20:25:30 das Exp $ */ #include "tclInt.h" #ifdef NO_DLFCN_H # include "../compat/dlfcn.h" #else # include <dlfcn.h> |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | #ifndef RTLD_GLOBAL # define RTLD_GLOBAL 0 #endif /* *--------------------------------------------------------------------------- * | | < | | < < < | | < < < < < | < < < > > | > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | < < < < < < < < < < < < < | | 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 |
#ifndef RTLD_GLOBAL
# define RTLD_GLOBAL 0
#endif
/*
*---------------------------------------------------------------------------
*
* 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 interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*
*---------------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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. */
{
VOID *handle;
CONST char *native;
native = Tcl_FSGetNativePath(pathPtr);
handle = dlopen(native, RTLD_NOW | RTLD_GLOBAL); /* INTL: Native. */
if (handle == NULL) {
Tcl_AppendResult(interp, "couldn't load file \"",
Tcl_GetString(pathPtr),
"\": ", dlerror(), (char *) NULL);
return TCL_ERROR;
}
*unloadProcPtr = &TclpUnloadFile;
*loadHandle = (Tcl_LoadHandle)handle;
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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
CONST char *native;
Tcl_DString newName, ds;
VOID *handle = (VOID*)loadHandle;
Tcl_PackageInitProc *proc;
/*
* Some platforms still add an underscore to the beginning of symbol
* names. If we can't find a name without an underscore, try again
* with the underscore.
*/
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
native);
if (proc == NULL) {
Tcl_DStringInit(&newName);
Tcl_DStringAppend(&newName, "_", 1);
native = Tcl_DStringAppend(&newName, native, -1);
proc = (Tcl_PackageInitProc *) dlsym(handle, /* INTL: Native. */
native);
Tcl_DStringFree(&newName);
}
Tcl_DStringFree(&ds);
return proc;
}
/*
*----------------------------------------------------------------------
*
* TclpUnloadFile --
*
|
| ︙ | ︙ | |||
143 144 145 146 147 148 149 | * Side effects: * Code removed from memory. * *---------------------------------------------------------------------- */ void | | | | | | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 |
* Side effects:
* Code removed from memory.
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
VOID *handle;
handle = (VOID *) loadHandle;
dlclose(handle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
|
| ︙ | ︙ |
Changes to unix/tclLoadDld.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * makes more sense to use "dl_open" etc. * * 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. * | | | < | | < < < | | < < < < < | | | 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 |
* makes more sense to use "dl_open" etc.
*
* 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: tclLoadDld.c,v 1.6.2.2 2002/08/20 20:25:30 das Exp $
*/
#include "tclInt.h"
#include "dld.h"
/*
* In some systems, like SunOS 4.1.3, the RTLD_NOW flag isn't defined
* and this argument to dlopen must always be 1.
*/
#ifndef RTLD_NOW
# define RTLD_NOW 1
#endif
/*
*----------------------------------------------------------------------
*
* 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 interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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. */
{
static int firstTime = 1;
int returnCode;
char *fileName = Tcl_GetString(pathPtr);
/*
* The dld package needs to know the pathname to the tcl binary.
* If that's not known, return an error.
*/
if (firstTime) {
if (tclExecutableName == NULL) {
Tcl_SetResult(interp,
"don't know name of application binary file, so can't initialize dynamic loader",
TCL_STATIC);
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 |
if ((returnCode = dld_link(Tcl_GetString(pathPtr))) != 0) {
Tcl_AppendResult(interp, "couldn't load file \"",
Tcl_GetString(pathPtr),
"\": ", dld_strerror(returnCode), (char *) NULL);
return TCL_ERROR;
}
| < < | > > > > > > > > > > > > > > > > > > > > > > > > | | | | | 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 |
if ((returnCode = dld_link(Tcl_GetString(pathPtr))) != 0) {
Tcl_AppendResult(interp, "couldn't load file \"",
Tcl_GetString(pathPtr),
"\": ", dld_strerror(returnCode), (char *) NULL);
return TCL_ERROR;
}
*loadHandle = strcpy(
(char *) ckalloc((unsigned) (strlen(fileName) + 1)), fileName);
*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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
return (Tcl_PackageInitProc *) dld_get_func(symbol);
}
/*
*----------------------------------------------------------------------
*
* 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 removed from memory.
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
char *fileName;
handle = (char *) loadHandle;
dld_unlink_by_file(handle, 0);
ckfree(handle);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to unix/tclLoadDyld.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclLoadDyld.c -- * * This procedure provides a version of the TclLoadFile that * works with Apple's dyld dynamic loading. This file * provided by Wilfredo Sanchez (wsanchez@apple.com). * This works on Mac OS X. * * Copyright (c) 1995 Apple Computer, 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 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 |
/*
* tclLoadDyld.c --
*
* This procedure provides a version of the TclLoadFile that
* works with Apple's dyld dynamic loading. This file
* provided by Wilfredo Sanchez (wsanchez@apple.com).
* This works on Mac OS X.
*
* Copyright (c) 1995 Apple Computer, Inc.
*
* 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.5.2.4 2002/08/20 20:25:30 das Exp $
*/
#include "tclInt.h"
#include "tclPort.h"
#include <mach-o/dyld.h>
typedef struct Tcl_DyldModuleHandle {
struct Tcl_DyldModuleHandle *nextModuleHandle;
NSModule module;
} Tcl_DyldModuleHandle;
typedef struct Tcl_DyldLoadHandle {
const struct mach_header *dyld_lib;
Tcl_DyldModuleHandle *firstModuleHandle;
} Tcl_DyldLoadHandle;
/*
*----------------------------------------------------------------------
*
* 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.
*
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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 *dyld_lib;
CONST char *native;
native = Tcl_FSGetNativePath(pathPtr);
dyld_lib = NSAddImage(native,
NSADDIMAGE_OPTION_WITH_SEARCHING |
NSADDIMAGE_OPTION_RETURN_ON_ERROR);
if (!dyld_lib) {
NSLinkEditErrors editError;
char *name, *msg;
NSLinkEditError(&editError, &errno, &name, &msg);
Tcl_AppendResult(interp, msg, (char *) NULL);
return TCL_ERROR;
}
dyldLoadHandle = (Tcl_DyldLoadHandle *) ckalloc(sizeof(Tcl_DyldLoadHandle));
if (!dyldLoadHandle) return TCL_ERROR;
dyldLoadHandle->dyld_lib = dyld_lib;
dyldLoadHandle->firstModuleHandle = NULL;
*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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
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);
nsSymbol = NSLookupSymbolInImage(dyldLoadHandle->dyld_lib, native,
NSLOOKUPSYMBOLINIMAGE_OPTION_BIND_NOW |
NSLOOKUPSYMBOLINIMAGE_OPTION_RETURN_ON_ERROR);
if(nsSymbol) {
Tcl_DyldModuleHandle *dyldModuleHandle;
proc = NSAddressOfSymbol(nsSymbol);
dyldModuleHandle = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle));
if (dyldModuleHandle) {
dyldModuleHandle->module = NSModuleForSymbol(nsSymbol);
dyldModuleHandle->nextModuleHandle = dyldLoadHandle->firstModuleHandle;
dyldLoadHandle->firstModuleHandle = dyldModuleHandle;
}
}
Tcl_DStringFree(&newName);
Tcl_DStringFree(&ds);
return proc;
}
/*
*----------------------------------------------------------------------
*
* TclpUnloadFile --
*
|
| ︙ | ︙ | |||
133 134 135 136 137 138 139 | * Code dissapears from memory. * Note that this is a no-op on older (OpenStep) versions of dyld. * *---------------------------------------------------------------------- */ void | | | | > > > | > > > > > > > | 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 |
* Code dissapears from memory.
* Note that this is a no-op on older (OpenStep) versions of dyld.
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
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 *dyldModuleHandle = dyldLoadHandle->firstModuleHandle;
void *ptr;
while (dyldModuleHandle) {
NSUnLinkModule(dyldModuleHandle->module, NSUNLINKMODULE_OPTION_NONE);
ptr = dyldModuleHandle;
dyldModuleHandle = dyldModuleHandle->nextModuleHandle;
ckfree(ptr);
}
ckfree(dyldLoadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ |
Changes to unix/tclLoadNext.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclLoadNext.c -- * * This procedure provides a version of the TclLoadFile that * works with NeXTs rld_* dynamic loading. This file provided * by Pedja Bogdanovich. * * 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 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 |
/*
* tclLoadNext.c --
*
* This procedure provides a version of the TclLoadFile that
* works with NeXTs rld_* dynamic loading. This file provided
* by Pedja Bogdanovich.
*
* 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: tclLoadNext.c,v 1.6.2.2 2002/08/20 20:25:30 das Exp $
*/
#include "tclInt.h"
#include <mach-o/rld.h>
#include <streams/streams.h>
/*
*----------------------------------------------------------------------
*
* 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 interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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. */
{
|
| ︙ | ︙ | |||
68 69 70 71 72 73 74 |
NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL);
NXCloseMemory(errorStream,NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream,NX_FREEBUFFER);
| | | | | < | | > > > > > > > > > > > > > > > > > > > > > | | | | | | < < < | | | | | 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 |
NXGetMemoryBuffer(errorStream,&data,&len,&maxlen);
Tcl_AppendResult(interp,"couldn't load file \"",fileName,"\": ",data,NULL);
NXCloseMemory(errorStream,NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream,NX_FREEBUFFER);
*loadHandle = (Tcl_LoadHandle)1; /* A dummy non-NULL value */
*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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
Tcl_PackageInitProc *proc=NULL;
if(symbol) {
char sym[strlen(symbol)+2];
sym[0]='_'; sym[1]=0; strcat(sym,symbol);
rld_lookup(NULL,sym,(unsigned long *)&proc);
}
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:
* Does nothing. Can anything be done?
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to unix/tclLoadOSF.c.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | * John Robert LoVerso <loverso@freebsd.osf.org> * * 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. * | | | < | | < < < | | < < < < < | | 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 |
* John Robert LoVerso <loverso@freebsd.osf.org>
*
* 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: tclLoadOSF.c,v 1.6.2.2 2002/08/20 20:25:30 das Exp $
*/
#include "tclInt.h"
#include <sys/types.h>
#include <loader.h>
/*
*----------------------------------------------------------------------
*
* 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 interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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. */
{
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 |
* My convention is to use a [OSF loader] package name the same as shlib,
* since the idiots never implemented ldr_lookup() and it is otherwise
* impossible to get a package name given a module.
*
* I build loadable modules with a makefile rule like
* ld ... -export $@: -o $@ $(OBJS)
*/
| | | | > | < > > > > > > > > > > > > > > > > > > > > > > > > | | | | 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 |
* My convention is to use a [OSF loader] package name the same as shlib,
* since the idiots never implemented ldr_lookup() and it is otherwise
* impossible to get a package name given a module.
*
* I build loadable modules with a makefile rule like
* ld ... -export $@: -o $@ $(OBJS)
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
pkg = fileName;
} else {
pkg++;
}
*loadHandle = pkg;
*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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
return ldr_lookup_package((char *)loadHandle, symbol);
}
/*
*----------------------------------------------------------------------
*
* 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:
* Does nothing. Can anything be done?
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ |
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 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 |
/*
* 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.8.2.2 2002/08/20 20:25:30 das Exp $
*/
#include <dl.h>
/*
* On some HP machines, dl.h defines EXTERN; remove that definition.
*/
#ifdef EXTERN
# undef EXTERN
#endif
#include "tclInt.h"
/*
*----------------------------------------------------------------------
*
* 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 interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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. */
{
shl_t handle;
char *fileName = Tcl_GetString(pathPtr);
/*
* The flags below used to be BIND_IMMEDIATE; they were changed at
* the suggestion of Wolfgang Kechel (wolfgang@prs.de): "This
* enables verbosity for missing symbols when loading a shared lib
* 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."
*/
handle = shl_load(fileName,
BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH,
0L);
if (handle == NULL) {
Tcl_AppendResult(interp, "couldn't load file \"", fileName,
"\": ", Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
*loadHandle = (Tcl_LoadHandle) handle;
*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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
Tcl_DString newName;
Tcl_PackageInitProc *proc=NULL;
shl_t handle = (shl_t)loadHandle;
/*
* Some versions of the HP system software still use "_" at the
* beginning of exported symbols while others don't; try both
* forms of each name.
*/
if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE, (void *) &proc)
!= 0) {
Tcl_DStringInit(&newName);
Tcl_DStringAppend(&newName, "_", 1);
Tcl_DStringAppend(&newName, symbol, -1);
if (shl_findsym(&handle, Tcl_DStringValue(&newName),
(short) TYPE_PROCEDURE, (void *) &proc) != 0) {
proc = NULL;
}
Tcl_DStringFree(&newName);
}
return proc;
}
/*
*----------------------------------------------------------------------
*
* TclpUnloadFile --
*
|
| ︙ | ︙ | |||
136 137 138 139 140 141 142 | * Side effects: * Code removed from memory. * *---------------------------------------------------------------------- */ void | | | | | | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 |
* Side effects:
* Code removed from memory.
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
shl_t handle;
handle = (shl_t) loadHandle;
shl_unload(handle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
|
| ︙ | ︙ |
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.21.8.3 2002/08/20 20:25:30 das Exp $ */ #include "tclInt.h" /* Internal definitions for Tcl. */ #include "tclPort.h" /* Portability features for Tcl. */ /* * sys/ioctl.h has already been included by tclPort.h. Including termios.h |
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
{
FileState *fsPtr = (FileState *) instanceData;
Tcl_WideInt oldLoc, newLoc;
/*
* Save our current place in case we need to roll-back the seek.
*/
| | | | | 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 |
{
FileState *fsPtr = (FileState *) instanceData;
Tcl_WideInt oldLoc, newLoc;
/*
* Save our current place in case we need to roll-back the seek.
*/
oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
if (oldLoc == Tcl_LongAsWide(-1)) {
/*
* Bad things are happening. Error out...
*/
*errorCodePtr = errno;
return -1;
}
newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
/*
* Check for expressability in our return type, and roll-back otherwise.
*/
if (newLoc > Tcl_LongAsWide(INT_MAX)) {
*errorCodePtr = EOVERFLOW;
TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
return -1;
} else {
*errorCodePtr = (newLoc == Tcl_LongAsWide(-1)) ? errno : 0;
}
return (int) Tcl_WideAsLong(newLoc);
}
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 |
int mode; /* Relative to where should we seek? Can be
* one of SEEK_START, SEEK_CUR or SEEK_END. */
int *errorCodePtr; /* To store error code. */
{
FileState *fsPtr = (FileState *) instanceData;
Tcl_WideInt newLoc;
| | | 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 |
int mode; /* Relative to where should we seek? Can be
* one of SEEK_START, SEEK_CUR or SEEK_END. */
int *errorCodePtr; /* To store error code. */
{
FileState *fsPtr = (FileState *) instanceData;
Tcl_WideInt newLoc;
newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
*errorCodePtr = (newLoc == -1) ? errno : 0;
return newLoc;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1742 1743 1744 1745 1746 1747 1748 | * May open the channel and may cause creation of a file on the * file system. * *---------------------------------------------------------------------- */ Tcl_Channel | | | < | < < < < | 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 |
* May open the channel and may cause creation of a file on the
* file system.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *pathPtr; /* Name of file to open. */
int mode; /* POSIX open mode. */
int permissions; /* If the open involves creating a
* file, with what modes to create
* it? */
{
int fd, channelPermissions;
FileState *fsPtr;
CONST char *native, *translation;
char channelName[16 + TCL_INTEGER_SPACE];
Tcl_ChannelType *channelTypePtr;
#ifdef SUPPORTS_TTY
int ctl_tty;
#endif /* SUPPORTS_TTY */
#ifdef DEPRECATED
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif /* DEPRECATED */
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
channelPermissions = TCL_READABLE;
break;
case O_WRONLY:
channelPermissions = TCL_WRITABLE;
break;
|
| ︙ | ︙ | |||
1790 1791 1792 1793 1794 1795 1796 |
return NULL;
}
native = Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return NULL;
}
| | | 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 |
return NULL;
}
native = Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return NULL;
}
fd = TclOSopen(native, mode, permissions);
#ifdef SUPPORTS_TTY
ctl_tty = (strcmp (native, "/dev/tty") == 0);
#endif /* SUPPORTS_TTY */
if (fd < 0) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
|
| ︙ | ︙ | |||
1844 1845 1846 1847 1848 1849 1850 |
#endif /* DEPRECATED */
fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
fsPtr->fd = fd;
fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
(ClientData) fsPtr, channelPermissions);
| < < < < < < < < < < < < | 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 |
#endif /* DEPRECATED */
fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
fsPtr->fd = fd;
fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
(ClientData) fsPtr, channelPermissions);
if (translation != NULL) {
/*
* Gotcha. Most modems need a "\r" at the end of the command
* sequence. If you just send "at\n", the modem will not respond
* with "OK" because it never got a "\r" to actually invoke the
* command. So, by default, newlines are translated to "\r\n" on
* output to avoid "bug" reports that the serial port isn't working.
|
| ︙ | ︙ | |||
1905 1906 1907 1908 1909 1910 1911 |
char channelName[16 + TCL_INTEGER_SPACE];
int fd = (int) handle;
Tcl_ChannelType *channelTypePtr;
#ifdef DEPRECATED
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif /* DEPRECATED */
int socketType = 0;
| | | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 |
char channelName[16 + TCL_INTEGER_SPACE];
int fd = (int) handle;
Tcl_ChannelType *channelTypePtr;
#ifdef DEPRECATED
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif /* DEPRECATED */
int socketType = 0;
socklen_t argLength = sizeof(int);
if (mode == 0) {
return NULL;
}
/*
|
| ︙ | ︙ | |||
2260 2261 2262 2263 2264 2265 2266 |
Tcl_DString *dsPtr; /* Where to store the computed
* value; initialized by caller. */
{
TcpState *statePtr = (TcpState *) instanceData;
struct sockaddr_in sockname;
struct sockaddr_in peername;
struct hostent *hostEntPtr;
| | | | 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 |
Tcl_DString *dsPtr; /* Where to store the computed
* value; initialized by caller. */
{
TcpState *statePtr = (TcpState *) instanceData;
struct sockaddr_in sockname;
struct sockaddr_in peername;
struct hostent *hostEntPtr;
socklen_t size = sizeof(struct sockaddr_in);
size_t len = 0;
char buf[TCL_INTEGER_SPACE];
if (optionName != (char *) NULL) {
len = strlen(optionName);
}
if ((len > 1) && (optionName[1] == 'e') &&
(strncmp(optionName, "-error", len) == 0)) {
socklen_t optlen = sizeof(int);
int err, ret;
ret = getsockopt(statePtr->fd, SOL_SOCKET, SO_ERROR,
(char *)&err, &optlen);
if (ret < 0) {
err = errno;
}
|
| ︙ | ︙ | |||
2884 2885 2886 2887 2888 2889 2890 |
ClientData data; /* Callback token. */
int mask; /* Not used. */
{
TcpState *sockState; /* Client data of server socket. */
int newsock; /* The new client socket */
TcpState *newSockState; /* State for new socket. */
struct sockaddr_in addr; /* The remote address */
| | | 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 |
ClientData data; /* Callback token. */
int mask; /* Not used. */
{
TcpState *sockState; /* Client data of server socket. */
int newsock; /* The new client socket */
TcpState *newSockState; /* State for new socket. */
struct sockaddr_in addr; /* The remote address */
socklen_t len; /* For accept interface */
char channelName[16 + TCL_INTEGER_SPACE];
sockState = (TcpState *) data;
len = sizeof(struct sockaddr_in);
newsock = accept(sockState->fd, (struct sockaddr *) &addr, &len);
if (newsock < 0) {
|
| ︙ | ︙ | |||
2950 2951 2952 2953 2954 2955 2956 2957 2958 |
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
Tcl_Channel channel = NULL;
int fd = 0; /* Initializations needed to prevent */
int mode = 0; /* compiler warning (used before set). */
char *bufMode = NULL;
switch (type) {
case TCL_STDIN:
| > > > > > > | | | | | | > > > | 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 |
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
Tcl_Channel channel = NULL;
int fd = 0; /* Initializations needed to prevent */
int mode = 0; /* compiler warning (used before set). */
char *bufMode = NULL;
/*
* Some #def's to make the code a little clearer!
*/
#define ZERO_OFFSET ((Tcl_SeekOffset) 0)
#define ERROR_OFFSET ((Tcl_SeekOffset) -1)
switch (type) {
case TCL_STDIN:
if ((TclOSseek(0, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return (Tcl_Channel) NULL;
}
fd = 0;
mode = TCL_READABLE;
bufMode = "line";
break;
case TCL_STDOUT:
if ((TclOSseek(1, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return (Tcl_Channel) NULL;
}
fd = 1;
mode = TCL_WRITABLE;
bufMode = "line";
break;
case TCL_STDERR:
if ((TclOSseek(2, ZERO_OFFSET, SEEK_CUR) == ERROR_OFFSET)
&& (errno == EBADF)) {
return (Tcl_Channel) NULL;
}
fd = 2;
mode = TCL_WRITABLE;
bufMode = "none";
break;
default:
panic("TclGetDefaultStdChannel: Unexpected channel type");
break;
}
#undef ZERO_OFFSET
#undef ERROR_OFFSET
channel = Tcl_MakeFileChannel((ClientData) fd, mode);
if (channel == NULL) {
return NULL;
}
/*
* Set up the normal channel options for stdio handles.
|
| ︙ | ︙ |
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.13.2.4 2002/08/20 20:25:30 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. * |
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */
&& (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
&& (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
dirPtr = opendir(dst); /* INTL: Native. */
if (dirPtr != NULL) {
while (1) {
| | | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 |
if ((Realpath((char *) src, srcPath) != NULL) /* INTL: Native. */
&& (Realpath((char *) dst, dstPath) != NULL) /* INTL: Native. */
&& (strncmp(srcPath, dstPath, strlen(srcPath)) != 0)) {
dirPtr = opendir(dst); /* INTL: Native. */
if (dirPtr != NULL) {
while (1) {
dirEntPtr = TclOSreaddir(dirPtr); /* INTL: Native. */
if (dirEntPtr == NULL) {
break;
}
if ((strcmp(dirEntPtr->d_name, ".") != 0) &&
(strcmp(dirEntPtr->d_name, "..") != 0)) {
errno = EEXIST;
closedir(dirPtr);
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
{
Tcl_StatBuf srcStatBuf, dstStatBuf;
/*
* Have to do a stat() to determine the filetype.
*/
| | | | 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 |
{
Tcl_StatBuf srcStatBuf, dstStatBuf;
/*
* Have to do a stat() to determine the filetype.
*/
if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */
return TCL_ERROR;
}
if (S_ISDIR(srcStatBuf.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
*/
if (TclOSlstat(dst, &dstStatBuf) == 0) { /* INTL: Native. */
if (S_ISDIR(dstStatBuf.st_mode)) {
errno = EISDIR;
return TCL_ERROR;
}
}
if (unlink(dst) != 0) { /* INTL: Native. */
if (errno != ENOENT) {
|
| ︙ | ︙ | |||
434 435 436 437 438 439 440 |
{
int srcFd;
int dstFd;
u_int blockSize; /* Optimal I/O blocksize for filesystem */
char *buffer; /* Data buffer for copy */
size_t nread;
| | | | | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
{
int srcFd;
int dstFd;
u_int 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. */
statBufPtr->st_mode);
if (dstFd < 0) {
close(srcFd);
return TCL_ERROR;
}
#ifdef HAVE_ST_BLKSIZE
blockSize = statBufPtr->st_blksize;
|
| ︙ | ︙ | |||
714 715 716 717 718 719 720 |
path = Tcl_DStringValue(pathPtr);
if (recursive != 0) {
/* We should try to change permissions so this can be deleted */
Tcl_StatBuf statBuf;
int newPerm;
| | | 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 |
path = Tcl_DStringValue(pathPtr);
if (recursive != 0) {
/* We should try to change permissions so this can be deleted */
Tcl_StatBuf statBuf;
int newPerm;
if (TclOSstat(path, &statBuf) == 0) {
oldPerm = (mode_t) (statBuf.st_mode & 0x00007FFF);
}
newPerm = oldPerm | (64+128+256);
chmod(path, (mode_t) newPerm);
}
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
DIR *dirPtr;
errfile = NULL;
result = TCL_OK;
targetLen = 0; /* lint. */
source = Tcl_DStringValue(sourcePtr);
| | | 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 |
DIR *dirPtr;
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
*/
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 |
Tcl_DStringAppend(sourcePtr, "/", 1);
sourceLen = Tcl_DStringLength(sourcePtr);
if (targetPtr != NULL) {
Tcl_DStringAppend(targetPtr, "/", 1);
targetLen = Tcl_DStringLength(targetPtr);
}
| | | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 |
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 ((strcmp(dirEntPtr->d_name, ".") == 0)
|| (strcmp(dirEntPtr->d_name, "..") == 0)) {
continue;
}
/*
* Append name after slash, and recurse on the file.
|
| ︙ | ︙ | |||
900 901 902 903 904 905 906 | } /* *---------------------------------------------------------------------- * * TraversalCopy * | | | | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 | } /* *---------------------------------------------------------------------- * * TraversalCopy * * Called from TraverseUnixTree in order to execute a recursive copy * of a directory. * * Results: * Standard Tcl result. * * Side effects: * The file or directory src may be copied to dst, depending on * the value of type. |
| ︙ | ︙ | |||
927 928 929 930 931 932 933 |
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),
| | | 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 |
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)) == TCL_OK) {
return TCL_OK;
}
break;
case DOTREE_PRED:
if (DoCreateDirectory(Tcl_DStringValue(dstPtr)) == TCL_OK) {
return TCL_OK;
|
| ︙ | ︙ | |||
1671 1672 1673 1674 1675 1676 1677 |
#endif
currentPathEndPosition = path + nextCheckpoint;
while (1) {
cur = *currentPathEndPosition;
if ((cur == '/') && (path != currentPathEndPosition)) {
| | > | < | < | 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 |
#endif
currentPathEndPosition = path + nextCheckpoint;
while (1) {
cur = *currentPathEndPosition;
if ((cur == '/') && (path != currentPathEndPosition)) {
/* Reached directory separator */
Tcl_DString ds;
CONST char *nativePath;
int accessOk;
nativePath = Tcl_UtfToExternalDString(NULL, path,
currentPathEndPosition - path, &ds);
accessOk = access(nativePath, F_OK);
Tcl_DStringFree(&ds);
if (accessOk != 0) {
/* File doesn't exist */
break;
}
/* Update the acceptable point */
nextCheckpoint = currentPathEndPosition - path;
} else if (cur == 0) {
/* Reached end of string */
break;
}
currentPathEndPosition++;
}
/*
* 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 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) {
/*
* Free up the native path and put in its place the
* converted, normalized path.
*/
Tcl_DStringFree(&ds);
|
| ︙ | ︙ |
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.12.8.3 2002/08/20 20:25:30 das Exp $ */ #include "tclInt.h" #include "tclPort.h" static int NativeMatchType(CONST char* nativeName, Tcl_GlobTypeData *types); |
| ︙ | ︙ | |||
114 115 116 117 118 119 120 | /* * INTL: The following calls to access() and stat() should not be * converted to Tclp routines because they need to operate on native * strings directly. */ | | | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
/*
* INTL: The following calls to access() and stat() should not be
* converted to Tclp routines because they need to operate on native
* strings directly.
*/
if ((access(name, X_OK) == 0) /* INTL: Native. */
&& (TclOSstat(name, &statBuf) == 0) /* INTL: Native. */
&& S_ISREG(statBuf.st_mode)) {
goto gotName;
}
if (*p == '\0') {
break;
} else if (*(p+1) == 0) {
p = "./";
|
| ︙ | ︙ | |||
269 270 271 272 273 274 275 | /* * Now open the directory for reading and iterate over the contents. */ native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); | | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
/*
* 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. */
|| !S_ISDIR(statBuf.st_mode)) {
Tcl_DStringFree(&dsOrig);
Tcl_DStringFree(&ds);
return TCL_OK;
}
d = opendir(native); /* INTL: Native. */
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
nativeDirLen = Tcl_DStringLength(&ds);
while (1) {
Tcl_DString utfDs;
CONST char *utf;
Tcl_DirEntry *entryPtr;
| | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
nativeDirLen = Tcl_DStringLength(&ds);
while (1) {
Tcl_DString utfDs;
CONST char *utf;
Tcl_DirEntry *entryPtr;
entryPtr = TclOSreaddir(d); /* INTL: Native. */
if (entryPtr == NULL) {
break;
}
if (types != NULL && (types->perm & TCL_GLOB_PERM_HIDDEN)) {
/*
* We explicitly asked for hidden files, so turn around
* and ignore any file which isn't hidden.
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
if (types == NULL) {
/*
* Simply check for the file's existence, but do it
* with lstat, in case it is a link to a file which
* doesn't exist (since that case would not show up
* if we used 'access' or 'stat')
*/
| | | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
if (types == NULL) {
/*
* Simply check for the file's existence, but do it
* with lstat, in case it is a link to a file which
* doesn't exist (since that case would not show up
* if we used 'access' or 'stat')
*/
if (TclOSlstat(nativeEntry, &buf) != 0) {
return 0;
}
} else {
if (types->perm != 0) {
if (TclOSstat(nativeEntry, &buf) != 0) {
/*
* Either the file has disappeared between the
* 'readdir' call and the 'stat' call, or
* the file is a link to a file which doesn't
* exist (which we could ascertain with
* lstat), or there is some other strange
* problem. In all these cases, we define this
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
) {
return 0;
}
}
if (types->type != 0) {
if (types->perm == 0) {
/* We haven't yet done a stat on the file */
| | | | | | | | 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 |
) {
return 0;
}
}
if (types->type != 0) {
if (types->perm == 0) {
/* We haven't yet done a stat on the file */
if (TclOSstat(nativeEntry, &buf) != 0) {
/* Posix error occurred */
return 0;
}
}
/*
* In order bcdpfls as in 'find -t'
*/
if (
((types->type & TCL_GLOB_TYPE_BLOCK) &&
S_ISBLK(buf.st_mode)) ||
((types->type & TCL_GLOB_TYPE_CHAR) &&
S_ISCHR(buf.st_mode)) ||
((types->type & TCL_GLOB_TYPE_DIR) &&
S_ISDIR(buf.st_mode)) ||
((types->type & TCL_GLOB_TYPE_PIPE) &&
S_ISFIFO(buf.st_mode)) ||
((types->type & TCL_GLOB_TYPE_FILE) &&
S_ISREG(buf.st_mode))
#ifdef S_ISSOCK
|| ((types->type & TCL_GLOB_TYPE_SOCK) &&
S_ISSOCK(buf.st_mode))
#endif /* S_ISSOCK */
) {
/* Do nothing -- this file is ok */
} else {
#ifdef S_ISLNK
if (types->type & TCL_GLOB_TYPE_LINK) {
if (TclOSlstat(nativeEntry, &buf) == 0) {
if (S_ISLNK(buf.st_mode)) {
return 1;
}
}
}
#endif /* S_ISLNK */
return 0;
}
}
}
return 1;
}
|
| ︙ | ︙ | |||
577 578 579 580 581 582 583 |
*/
int
TclpObjLstat(pathPtr, bufPtr)
Tcl_Obj *pathPtr; /* Path of file to stat */
Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
{
| | | 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 |
*/
int
TclpObjLstat(pathPtr, bufPtr)
Tcl_Obj *pathPtr; /* Path of file to stat */
Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
{
return TclOSlstat(Tcl_FSGetNativePath(pathPtr), bufPtr);
}
/*
*---------------------------------------------------------------------------
*
* TclpObjGetCwd --
*
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 |
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
return Tcl_DStringValue(linkPtr);
#else
| | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
return Tcl_DStringValue(linkPtr);
#else
return NULL;
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpObjStat --
|
| ︙ | ︙ | |||
712 713 714 715 716 717 718 |
Tcl_Obj *pathPtr; /* Path of file to stat */
Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
{
CONST char *path = Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
} else {
| | | > > > > | > > | > > > | > > > > | > > > > > > > > > | > > > > > > > > | > | > > > | | | > | 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 |
Tcl_Obj *pathPtr; /* Path of file to stat */
Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */
{
CONST char *path = Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
} else {
return TclOSstat(path, bufPtr);
}
}
#ifdef S_IFLNK
Tcl_Obj*
TclpObjLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr;
Tcl_Obj *toPtr;
int linkAction;
{
if (toPtr != NULL) {
CONST char *src = Tcl_FSGetNativePath(pathPtr);
CONST char *target = Tcl_FSGetNativePath(toPtr);
if (src == NULL || target == NULL) {
return NULL;
}
if (access(src, F_OK) != -1) {
/* src exists */
errno = EEXIST;
return NULL;
}
if (access(target, F_OK) == -1) {
/* target doesn't exist */
errno = ENOENT;
return NULL;
}
/*
* Check symbolic link flag first, since we prefer to
* create these.
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
if (symlink(target, src) != 0) return NULL;
} else if (linkAction & TCL_CREATE_HARD_LINK) {
if (link(target, src) != 0) return NULL;
} else {
errno = ENODEV;
return NULL;
}
return toPtr;
} else {
Tcl_Obj* linkPtr = NULL;
char link[MAXPATHLEN];
int length;
char *native;
Tcl_DString ds;
if (Tcl_FSGetTranslatedPath(NULL, pathPtr) == NULL) {
return NULL;
}
length = readlink(Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
if (length < 0) {
return NULL;
}
/*
* Allocate and copy the name, taking care since the
* name need not be null terminated.
*/
native = (char*)ckalloc((unsigned)(1+length));
strncpy(native, link, (unsigned)length);
native[length] = '\0';
Tcl_ExternalToUtfDString(NULL, native, length, &ds);
linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
if (linkPtr != NULL) {
Tcl_IncrRefCount(linkPtr);
}
return linkPtr;
}
}
#endif
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ |
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 | /* * 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.24.8.5 2002/08/20 20:25:30 das Exp $ */ #if defined(HAVE_CFBUNDLE) #include <CoreFoundation/CoreFoundation.h> #endif #include "tclInt.h" #include "tclPort.h" |
| ︙ | ︙ | |||
135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
{"ru_RU", "iso8859-5"},
{"ru_SU", "iso8859-5"},
{"zh", "cp936"},
{NULL, NULL}
};
/*
*---------------------------------------------------------------------------
*
* TclpInitPlatform --
*
* Initialize all the platform-dependant things like signals and
| > > > | 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
{"ru_RU", "iso8859-5"},
{"ru_SU", "iso8859-5"},
{"zh", "cp936"},
{NULL, NULL}
};
static int Tcl_MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath);
/*
*---------------------------------------------------------------------------
*
* TclpInitPlatform --
*
* Initialize all the platform-dependant things like signals and
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
/*
* 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.
*/
| > > > > > > > > > | > > | 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 |
/*
* 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_CFBUNDLE
char tclLibPath[1024];
if (Tcl_MacOSXGetLibraryPath(NULL, 1024, tclLibPath) == TCL_OK) {
str = tclLibPath;
} else
#endif /* HAVE_CFBUNDLE */
{
str = defaultLibraryDir;
}
if (str[0] != '\0') {
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
TclSetLibraryPath(pathPtr);
Tcl_DStringFree(&buffer);
}
/*
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 |
struct utsname name;
#endif
int unameOK;
CONST char *user;
Tcl_DString ds;
#ifdef HAVE_CFBUNDLE
| < < < < < < < < < < < | < < < | | | | < | < | 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 |
struct utsname name;
#endif
int unameOK;
CONST char *user;
Tcl_DString ds;
#ifdef HAVE_CFBUNDLE
char tclLibPath[1024];
if (Tcl_MacOSXGetLibraryPath(interp, 1024, tclLibPath) == TCL_OK) {
Tcl_SetVar(interp, "tclDefaultLibrary", tclLibPath,
TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", tclLibPath, TCL_GLOBAL_ONLY);
} else
#endif /* HAVE_CFBUNDLE */
{
Tcl_SetVar(interp, "tclDefaultLibrary", defaultLibraryDir,
TCL_GLOBAL_ONLY);
Tcl_SetVar(interp, "tcl_pkgPath", pkgPath, TCL_GLOBAL_ONLY);
}
#ifdef DJGPP
Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY);
#else
Tcl_SetVar2(interp, "tcl_platform", "platform", "unix", TCL_GLOBAL_ONLY);
#endif
unameOK = 0;
#ifndef NO_UNAME
|
| ︙ | ︙ | |||
958 959 960 961 962 963 964 |
{
/*
* This function is unimplemented on Unix platforms.
*/
return 1;
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
{
/*
* This function is unimplemented on Unix platforms.
*/
return 1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_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_MacOSXOpenBundleResources.
*
*----------------------------------------------------------------------
*/
int Tcl_MacOSXGetLibraryPath(Tcl_Interp *interp, int maxPathLen, char *tclLibPath)
{
int foundInFramework = TCL_ERROR;
#ifdef HAVE_CFBUNDLE
if (strcmp(defaultLibraryDir, "@TCL_IN_FRAMEWORK@") == 0) {
foundInFramework = Tcl_MacOSXOpenBundleResources(interp,
"com.tcltk.tcllibrary",
0, maxPathLen, tclLibPath);
}
#endif
return foundInFramework;
}
|
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 | /* * 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.10.18.2 2002/08/20 20:25:30 das Exp $ */ #include "tclInt.h" #include "tclPort.h" #include <signal.h> extern TclStubs tclStubs; |
| ︙ | ︙ |
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.15.8.3 2002/08/20 20:25:30 das Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The following macros convert between TclFile's and fd's. The conversion |
| ︙ | ︙ | |||
136 137 138 139 140 141 142 |
int mode; /* In what mode to open the file? */
{
int fd;
CONST char *native;
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds);
| | | | 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 |
int mode; /* In what mode to open the file? */
{
int fd;
CONST char *native;
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, fname, -1, &ds);
fd = TclOSopen(native, mode, 0666); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (fd != -1) {
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) {
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.
*/
|
| ︙ | ︙ | |||
211 212 213 214 215 216 217 |
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
if (write(fd, native, strlen(native)) == -1) {
close(fd);
Tcl_DStringFree(&dstring);
return NULL;
}
Tcl_DStringFree(&dstring);
| | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 |
native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
if (write(fd, native, strlen(native)) == -1) {
close(fd);
Tcl_DStringFree(&dstring);
return NULL;
}
Tcl_DStringFree(&dstring);
TclOSseek(fd, (Tcl_SeekOffset) 0, SEEK_SET);
}
return MakeFile(fd);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
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.18.8.2 2002/08/20 20:25:30 das Exp $ */ #ifndef _TCLUNIXPORT #define _TCLUNIXPORT #ifndef _TCLINT # include "tclInt.h" |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | #else # include <dirent.h> #endif #endif #ifdef HAVE_STRUCT_DIRENT64 typedef struct dirent64 Tcl_DirEntry; | | | | | | | | | | | | | | 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 | #else # include <dirent.h> #endif #endif #ifdef HAVE_STRUCT_DIRENT64 typedef struct dirent64 Tcl_DirEntry; # define TclOSreaddir readdir64 # define TclOSreaddir_r readdir64_r #else typedef struct dirent Tcl_DirEntry; # define TclOSreaddir readdir # define TclOSreaddir_r readdir_r #endif #ifdef HAVE_TYPE_OFF64_T typedef off64_t Tcl_SeekOffset; # define TclOSseek lseek64 # define TclOSopen open64 #else typedef off_t Tcl_SeekOffset; # define TclOSseek lseek # define TclOSopen open #endif #ifdef HAVE_STRUCT_STAT64 # define TclOSstat stat64 # define TclOSlstat lstat64 #else # define TclOSstat stat # define TclOSlstat lstat #endif #if !HAVE_STRTOLL && defined(TCL_WIDE_INT_TYPE) && !TCL_WIDE_INT_IS_LONG EXTERN Tcl_WideInt strtoll _ANSI_ARGS_((CONST char *string, char **endPtr, int base)); EXTERN Tcl_WideUInt strtoull _ANSI_ARGS_((CONST char *string, char **endPtr, int base)); |
| ︙ | ︙ | |||
320 321 322 323 324 325 326 327 328 | /* * On systems without symbolic links (i.e. S_IFLNK isn't defined) * define "lstat" to use "stat" instead. */ #ifndef S_IFLNK # define lstat stat # define lstat64 stat64 | > | | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 | /* * On systems without symbolic links (i.e. S_IFLNK isn't defined) * define "lstat" to use "stat" instead. */ #ifndef S_IFLNK # undef TclOSlstat # define lstat stat # define lstat64 stat64 # define TclOSlstat TclOSstat #endif /* * Define macros to query file type bits, if they're not already * defined. */ |
| ︙ | ︙ | |||
556 557 558 559 560 561 562 | EXTERN struct tm * TclpLocaltime(time_t *); EXTERN struct tm * TclpGmtime(time_t *); EXTERN char * TclpInetNtoa(struct in_addr); #define readdir(x) TclpReaddir(x) #define localtime(x) TclpLocaltime(x) #define gmtime(x) TclpGmtime(x) #define inet_ntoa(x) TclpInetNtoa(x) | | | | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 | EXTERN struct tm * TclpLocaltime(time_t *); EXTERN struct tm * TclpGmtime(time_t *); EXTERN char * TclpInetNtoa(struct in_addr); #define readdir(x) TclpReaddir(x) #define localtime(x) TclpLocaltime(x) #define gmtime(x) TclpGmtime(x) #define inet_ntoa(x) TclpInetNtoa(x) #undef TclOSreaddir #define TclOSreaddir(x) TclpReaddir(x) #else typedef int TclpMutex; #define TclpMutexInit(a) #define TclpMutexLock(a) #define TclpMutexUnlock(a) #endif /* TCL_THREADS */ #include "tclPlatDecls.h" #include "tclIntPlatDecls.h" #endif /* _TCLUNIXPORT */ |
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.11.18.1 2002/08/20 20:25:30 das Exp $ */ #include "tclInt.h" #include "tclPort.h" /* * The headers are needed for the testalarm command that verifies the |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | /* * Forward declarations of procedures defined later in this file: */ static void TestFileHandlerProc _ANSI_ARGS_((ClientData clientData, int mask)); static int TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy, | | | | | | | | | | 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 | /* * Forward declarations of procedures defined later in this file: */ static void TestFileHandlerProc _ANSI_ARGS_((ClientData clientData, int mask)); static int TestfilehandlerCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestfilewaitCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestfindexecutableCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestgetopenfileCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestgetdefencdirCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *interp, int argc, CONST char **argv)); static int TestsetdefencdirCmd _ANSI_ARGS_((ClientData dummy, 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 -- * |
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
*/
static int
TestfilehandlerCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 |
*/
static int
TestfilehandlerCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Pipe *pipePtr;
int i, mask, timeout;
static int initialized = 0;
char buffer[4000];
TclFile file;
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 |
TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "oneevent") == 0) {
Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
} else if (strcmp(argv[1], "wait") == 0) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
| | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 |
TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
Tcl_SetResult(interp, buf, TCL_VOLATILE);
} else if (strcmp(argv[1], "oneevent") == 0) {
Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
} else if (strcmp(argv[1], "wait") == 0) {
if (argc != 5) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"",
argv[0], " wait index readable|writable timeout\"",
(char *) NULL);
return TCL_ERROR;
}
if (pipePtr->readFile == NULL) {
Tcl_AppendResult(interp, "pipe ", argv[2], " doesn't exist",
(char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
*/
static int
TestfilewaitCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 |
*/
static int
TestfilewaitCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
int mask, result, timeout;
Tcl_Channel channel;
int fd;
ClientData data;
if (argc != 4) {
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
*/
static int
TestfindexecutableCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
*/
static int
TestfindexecutableCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
char *oldName;
char *oldNativeName;
if (argc != 2) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" argv0\"", (char *) NULL);
|
| ︙ | ︙ | |||
493 494 495 496 497 498 499 |
*/
static int
TestgetopenfileCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
*/
static int
TestgetopenfileCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
ClientData filePtr;
if (argc != 3) {
Tcl_AppendResult(interp,
"wrong # args: should be \"", argv[0],
" channelName forWriting\"",
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
*/
static int
TestsetdefencdirCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 |
*/
static int
TestsetdefencdirCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc != 2) {
Tcl_AppendResult(interp,
"wrong # args: should be \"", argv[0],
" defaultDir\"",
(char *) NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
582 583 584 585 586 587 588 |
*/
static int
TestgetdefencdirCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 |
*/
static int
TestgetdefencdirCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
if (argc != 1) {
Tcl_AppendResult(interp,
"wrong # args: should be \"", argv[0],
(char *) NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
619 620 621 622 623 624 625 |
*/
static int
TestalarmCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 |
*/
static int
TestalarmCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
#ifdef SA_RESTART
unsigned int sec;
struct sigaction action;
if (argc > 1) {
Tcl_GetInt(interp, argv[1], (int *)&sec);
|
| ︙ | ︙ | |||
696 697 698 699 700 701 702 |
*/
static int
TestgotsigCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 696 697 698 699 700 701 702 703 704 705 706 707 708 |
*/
static int
TestgotsigCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, gotsig, (char *) NULL);
gotsig = "0";
return TCL_OK;
}
|
Changes to unix/tclUnixThrd.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * * SCCS: @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12 */ #include "tclInt.h" #ifdef TCL_THREADS | > < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* SCCS: @(#) tclUnixThrd.c 1.18 98/02/19 14:24:12
*/
#include "tclInt.h"
#include "tclPort.h"
#ifdef TCL_THREADS
#include "pthread.h"
typedef struct ThreadSpecificData {
char nabuf[16];
struct tm gtbuf;
struct tm ltbuf;
struct {
|
| ︙ | ︙ | |||
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 |
pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr;
if (pcondPtr != NULL) {
pthread_cond_destroy(pcondPtr);
ckfree((char *)pcondPtr);
*condPtr = NULL;
}
}
/*
*----------------------------------------------------------------------
*
* TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa --
*
* These procedures replace core C versions to be used in a
* threaded environment.
*
* Results:
* See documentation of C functions.
*
* Side effects:
* See documentation of C functions.
*
*----------------------------------------------------------------------
*/
| > | < > > | | > > | | | | | | | | | > > > > > > > > | > | > > > > > > > > > > > > | 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 |
pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr;
if (pcondPtr != NULL) {
pthread_cond_destroy(pcondPtr);
ckfree((char *)pcondPtr);
*condPtr = NULL;
}
}
#endif /* TCL_THREADS */
/*
*----------------------------------------------------------------------
*
* TclpReaddir, TclpLocaltime, TclpGmtime, TclpInetNtoa --
*
* These procedures replace core C versions to be used in a
* threaded environment.
*
* Results:
* See documentation of C functions.
*
* Side effects:
* See documentation of C functions.
*
*----------------------------------------------------------------------
*/
#if defined(TCL_THREADS) && !defined(HAVE_READDIR_R)
TCL_DECLARE_MUTEX( rdMutex )
#undef readdir
#endif
Tcl_DirEntry *
TclpReaddir(DIR * dir)
{
Tcl_DirEntry *ent;
#ifdef TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#ifdef HAVE_READDIR_R
ent = &tsdPtr->rdbuf.ent;
if (TclOSreaddir_r(dir, ent, &ent) != 0) {
ent = NULL;
}
#else /* !HAVE_READDIR_R */
Tcl_MutexLock(&rdMutex);
# ifdef HAVE_STRUCT_DIRENT64
ent = readdir64(dir);
# else /* !HAVE_STRUCT_DIRENT64 */
ent = readdir(dir);
# endif /* HAVE_STRUCT_DIRENT64 */
if (ent != NULL) {
memcpy((VOID *) &tsdPtr->rdbuf.ent, (VOID *) ent,
sizeof(Tcl_DirEntry) + sizeof(char) * (PATH_MAX+1));
ent = &tsdPtr->rdbuf.ent;
}
Tcl_MutexUnlock(&rdMutex);
#endif /* HAVE_READDIR_R */
#else
# ifdef HAVE_STRUCT_DIRENT64
ent = readdir64(dir);
# else /* !HAVE_STRUCT_DIRENT64 */
ent = readdir(dir);
# endif /* HAVE_STRUCT_DIRENT64 */
#endif
return ent;
}
#if defined(TCL_THREADS) && (!defined(HAVE_GMTIME_R) || !defined(HAVE_LOCALTIME_R))
TCL_DECLARE_MUTEX( tmMutex )
#undef localtime
#undef gmtime
#endif
struct tm *
TclpLocaltime(time_t * clock)
{
#ifdef TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#ifdef HAVE_LOCALTIME_R
return localtime_r(clock, &tsdPtr->ltbuf);
#else
Tcl_MutexLock( &tmMutex );
memcpy( (VOID *) &tsdPtr->ltbuf, (VOID *) localtime( clock ), sizeof (struct tm) );
Tcl_MutexUnlock( &tmMutex );
return &tsdPtr->ltbuf;
#endif
#else
return localtime(clock);
#endif
}
struct tm *
TclpGmtime(time_t * clock)
{
#ifdef TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#ifdef HAVE_GMTIME_R
return gmtime_r(clock, &tsdPtr->gtbuf);
#else
Tcl_MutexLock( &tmMutex );
memcpy( (VOID *) &tsdPtr->gtbuf, (VOID *) gmtime( clock ), sizeof (struct tm) );
Tcl_MutexUnlock( &tmMutex );
return &tsdPtr->gtbuf;
#endif
#else
return gmtime(clock);
#endif
}
char *
TclpInetNtoa(struct in_addr addr)
{
#ifdef TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
union {
unsigned long l;
unsigned char b[4];
} u;
u.l = (unsigned long) addr.s_addr;
sprintf(tsdPtr->nabuf, "%u.%u.%u.%u", u.b[0], u.b[1], u.b[2], u.b[3]);
return tsdPtr->nabuf;
#else
return inet_ntoa(addr);
#endif
}
#ifdef TCL_THREADS
/*
* Additions by AOL for specialized thread memory allocator.
*/
#ifdef USE_THREAD_ALLOC
static int initialized = 0;
static pthread_key_t key;
static pthread_once_t once = PTHREAD_ONCE_INIT;
|
| ︙ | ︙ |
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 | /* * 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.11.12.3 2002/08/20 20:25:31 das 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; /* * If we fall back on the thread-unsafe versions of gmtime and localtime, * use this mutex to try to protect them. */ #if !defined(HAVE_GMTIME_R) || !defined(HAVE_LOCALTIME_R) TCL_DECLARE_MUTEX(tmMutex) #endif /* * Forward declarations for procedures defined later in this file. */ static struct tm *ThreadSafeGMTime _ANSI_ARGS_(( CONST time_t* )); |
| ︙ | ︙ | |||
328 329 330 331 332 333 334 335 336 337 338 339 340 341 |
sprintf(s, "Stardate %2d%03d.%01d",
(((t->tm_year + TM_YEAR_BASE) + 377) - 2323),
(((t->tm_yday + 1) * 1000) /
(365 + IsLeapYear((t->tm_year + TM_YEAR_BASE)))),
(((t->tm_hour * 60) + t->tm_min)/144));
return(strlen(s));
}
return strftime(s, maxsize, format, t);
}
/*
*----------------------------------------------------------------------
*
* ThreadSafeGMTime --
| > | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 |
sprintf(s, "Stardate %2d%03d.%01d",
(((t->tm_year + TM_YEAR_BASE) + 377) - 2323),
(((t->tm_yday + 1) * 1000) /
(365 + IsLeapYear((t->tm_year + TM_YEAR_BASE)))),
(((t->tm_hour * 60) + t->tm_min)/144));
return(strlen(s));
}
setlocale(LC_TIME, "");
return strftime(s, maxsize, format, t);
}
/*
*----------------------------------------------------------------------
*
* ThreadSafeGMTime --
|
| ︙ | ︙ | |||
349 350 351 352 353 354 355 | * Side effects: * Invokes gmtime or gmtime_r as appropriate. * *---------------------------------------------------------------------- */ static struct tm * | | < | | | | | | | 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 |
* Side effects:
* Invokes gmtime or gmtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
static struct tm *
ThreadSafeGMTime(timePtr)
CONST time_t *timePtr; /* Pointer to the number of seconds
* since the local system's epoch
*/
{
/*
* Get a thread-local buffer to hold the returned time.
*/
struct tm *tmPtr = (struct tm *)
Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_GMTIME_R
gmtime_r(timePtr, tmPtr);
#else
Tcl_MutexLock(&tmMutex);
memcpy((VOID *) tmPtr, (VOID *) gmtime(timePtr), sizeof(struct tm));
Tcl_MutexUnlock(&tmMutex);
#endif
return tmPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
390 391 392 393 394 395 396 | * Side effects: * Invokes localtime or localtime_r as appropriate. * *---------------------------------------------------------------------- */ static struct tm * | | < | | | | < | < | | 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 |
* Side effects:
* Invokes localtime or localtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
static struct tm *
ThreadSafeLocalTime(timePtr)
CONST time_t *timePtr; /* Pointer to the number of seconds
* since the local system's epoch
*/
{
/*
* Get a thread-local buffer to hold the returned time.
*/
struct tm *tmPtr = (struct tm *)
Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
localtime_r(timePtr, tmPtr);
#else
Tcl_MutexLock(&tmMutex);
memcpy((VOID *) tmPtr, (VOID *) localtime(timePtr), sizeof(struct tm));
Tcl_MutexUnlock(&tmMutex);
#endif
return tmPtr;
}
|
Changes to unix/tclXtTest.c.
1 2 3 4 5 6 7 8 9 10 | /* * tclXtTest.c -- * * Contains commands for Xt notifier specific tests on Unix. * * 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 | /* * tclXtTest.c -- * * Contains commands for Xt notifier specific tests on Unix. * * 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: tclXtTest.c,v 1.4.26.1 2002/08/20 20:25:31 das Exp $ */ #include <X11/Intrinsic.h> #include "tcl.h" static int TesteventloopCmd _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp, int argc, CONST char **argv)); extern void InitNotifier _ANSI_ARGS_((void)); /* *---------------------------------------------------------------------- * * Tclxttest_Init -- |
| ︙ | ︙ | |||
71 72 73 74 75 76 77 |
*/
static int
TesteventloopCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
| | | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
*/
static int
TesteventloopCmd(clientData, interp, argc, argv)
ClientData clientData; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
CONST 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],
|
| ︙ | ︙ |
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.55.2.3 2002/08/20 20:25:31 das 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 |
| ︙ | ︙ | |||
482 483 484 485 486 487 488 | do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ $(MKDIR) $$i; \ else true; \ fi; \ done; | | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 | do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ $(MKDIR) $$i; \ else true; \ fi; \ done; @for i in http1.0 http2.4 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; |
| ︙ | ︙ | |||
516 517 518 519 520 521 522 | $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http2.4"; \ done; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; | | | | | | 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http2.4"; \ 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"; @for j in $(ROOT_DIR)/library/msgcat/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/msgcat1.3"; \ done; @echo "Installing library tcltest2.2 directory"; @for j in $(ROOT_DIR)/library/tcltest/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/tcltest2.2"; \ done; @echo "Installing encodings"; @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ done; install-doc: doc |
| ︙ | ︙ | |||
582 583 584 585 586 587 588 | # # Regenerate the stubs files. # $(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ $(GENERIC_DIR)/tclInt.decls | > | > | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
#
# Regenerate the stubs files.
#
$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
$(GENERIC_DIR)/tclInt.decls
@echo "Warning: tclStubInit.c may be out of date."
@echo "Developers may want to run \"make genstubs\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
genstubs:
$(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \
"$(GENERIC_DIR_NATIVE)" \
"$(GENERIC_DIR_NATIVE)\tcl.decls" \
"$(GENERIC_DIR_NATIVE)\tclInt.decls"
|
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.26.8.2 2002/08/20 20:25:31 das Exp $ 1. Introduction --------------- This directory contains the binary distribution of Tcl/Tk 8.4b3 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/configure.
| ︙ | ︙ | |||
525 526 527 528 529 530 531 532 533 534 535 |
ac_n=-n ac_c= ac_t=
fi
else
ac_n= ac_c='\c' ac_t=
fi
TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
| > | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 |
ac_n=-n ac_c= ac_t=
fi
else
ac_n= ac_c='\c' ac_t=
fi
TCL_VERSION=8.4
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=4
TCL_PATCH_LEVEL="b3"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.2
TCL_DDE_MAJOR_VERSION=1
TCL_DDE_MINOR_VERSION=2
TCL_DDE_PATCH_LEVEL=""
DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION
|
| ︙ | ︙ | |||
570 571 572 573 574 575 576 |
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
| | | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
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:579: 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=":"
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 | 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 | | | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 |
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:609: 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=":"
|
| ︙ | ︙ | |||
651 652 653 654 655 656 657 |
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
| | | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 |
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:660: 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=":"
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 |
;;
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
| | | | | 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 |
;;
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:692: 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 703 "configure"
#include "confdefs.h"
main(){return(0);}
EOF
if { (eval echo configure:708: \"$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
|
| ︙ | ︙ | |||
725 726 727 728 729 730 731 |
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
| | | | | | 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 |
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:734: 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:739: 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:748: \"$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:767: 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
|
| ︙ | ︙ | |||
801 802 803 804 805 806 807 |
# 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
| | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 |
# 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:810: 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=":"
|
| ︙ | ︙ | |||
830 831 832 833 834 835 836 |
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
| | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
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:839: 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=":"
|
| ︙ | ︙ | |||
859 860 861 862 863 864 865 |
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
| | | 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
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:868: 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=":"
|
| ︙ | ︙ | |||
892 893 894 895 896 897 898 |
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
| | | 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 |
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:901: 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}"'
|
| ︙ | ︙ | |||
924 925 926 927 928 929 930 | #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- echo $ac_n "checking for Cygwin environment""... $ac_c" 1>&6 | | | | | 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 |
#--------------------------------------------------------------------
# Perform additinal compiler tests.
#--------------------------------------------------------------------
echo $ac_n "checking for Cygwin environment""... $ac_c" 1>&6
echo "configure:933: 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 938 "configure"
#include "confdefs.h"
int main() {
#ifndef __CYGWIN__
#define __CYGWIN__ __CYGWIN32__
#endif
return __CYGWIN__;
; return 0; }
EOF
if { (eval echo configure:949: \"$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
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
if test "$ac_cv_cygwin" = "yes" ; then
{ echo "configure: error: Compiling with the Cygwin version of gcc is not supported.
Use the Mingw version of gcc from www.mingw.org instead." 1>&2; exit 1; }
fi
echo $ac_n "checking for SEH support in compiler""... $ac_c" 1>&6
| | | | | 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 |
if test "$ac_cv_cygwin" = "yes" ; then
{ echo "configure: error: Compiling with the Cygwin version of gcc is not supported.
Use the Mingw version of gcc from www.mingw.org instead." 1>&2; exit 1; }
fi
echo $ac_n "checking for SEH support in compiler""... $ac_c" 1>&6
echo "configure:973: 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 981 "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:1000: \"$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
|
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 | fi #-------------------------------------------------------------------- # Determines the correct binary file extension (.o, .obj, .exe etc.) #-------------------------------------------------------------------- echo $ac_n "checking for object suffix""... $ac_c" 1>&6 | | | | | | | | | 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 |
fi
#--------------------------------------------------------------------
# Determines the correct binary file extension (.o, .obj, .exe etc.)
#--------------------------------------------------------------------
echo $ac_n "checking for object suffix""... $ac_c" 1>&6
echo "configure:1028: 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:1034: \"$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:1052: 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 1057 "configure"
#include "confdefs.h"
int main() {
return __MINGW32__;
; return 0; }
EOF
if { (eval echo configure:1064: \"$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:1083: 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:1093: \"$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
|
| ︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 |
#--------------------------------------------------------------------
# Check whether --enable-threads or --disable-threads was given.
#--------------------------------------------------------------------
echo $ac_n "checking for building with threads""... $ac_c" 1>&6
| | | 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 |
#--------------------------------------------------------------------
# Check whether --enable-threads or --disable-threads was given.
#--------------------------------------------------------------------
echo $ac_n "checking for building with threads""... $ac_c" 1>&6
echo "configure:1120: 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
|
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 |
#--------------------------------------------------------------------
# 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
| | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
#--------------------------------------------------------------------
# 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:1151: 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
|
| ︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 |
#--------------------------------------------------------------------
# Step 0: Enable 64 bit support?
echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
| | | | 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 |
#--------------------------------------------------------------------
# Step 0: Enable 64 bit support?
echo $ac_n "checking if 64bit support is requested""... $ac_c" 1>&6
echo "configure:1192: 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:1209: 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=":"
|
| ︙ | ︙ | |||
1237 1238 1239 1240 1241 1242 1243 |
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
| | | 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 |
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:1246: checking compiler flags" >&5
if test "${GCC}" = "yes" ; then
if test "$do64bit" = "yes" ; then
echo "configure: warning: "64bit mode not supported with GCC on Windows"" 1>&2
fi
SHLIB_LD=""
SHLIB_LD_LIBS=""
LIBS=""
|
| ︙ | ︙ | |||
1427 1428 1429 1430 1431 1432 1433 |
# 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
| | | 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 |
# 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:1436: 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
|
| ︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 |
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
| | | | | | | | | 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 |
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:1466: 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 1481 "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:1487: \"$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 1498 "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:1504: \"$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 1515 "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:1521: \"$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
|
| ︙ | ︙ | |||
1538 1539 1540 1541 1542 1543 1544 | 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 | | | | | 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 |
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:1547: 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 1552 "configure"
#include "confdefs.h"
#include <errno.h>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1557: \"$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
|
| ︙ | ︙ |
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 | #! /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.41.4.3 2002/08/20 20:25:31 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="b3" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.2 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=2 TCL_DDE_PATCH_LEVEL="" DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
| ︙ | ︙ |
Changes to win/makefile.bc.
| ︙ | ︙ | |||
398 399 400 401 402 403 404 | -@$(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.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.4" | | | | | | | | | > > > > | | | 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 | -@$(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.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.4" -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.4" -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.4" @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" -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.3" @echo installing tcltest2.2 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.2" -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.2" -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.2" @echo installing $(TCLDDEDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.1" -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.1" -@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.1" @echo installing $(TCLREGDLLNAME) -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.0" -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.0" -@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.0" @echo installing encoding files -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding" -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding" @echo installing library files -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)" -@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)" |
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001 ActiveState Corporation. # Copyright (c) 2001-2002 David Gravereaux. # #------------------------------------------------------------------------------ | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | # # Copyright (c) 1995-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # Copyright (c) 2001 ActiveState Corporation. # Copyright (c) 2001-2002 David Gravereaux. # #------------------------------------------------------------------------------ # RCS: @(#) $Id: makefile.vc,v 1.66.2.2 2002/08/20 20:25:31 das Exp $ #------------------------------------------------------------------------------ !if "$(MSVCDIR)" == "" MSG = ^ You'll need to run vcvars32.bat from Developer Studio, first, to setup^ the environment. Jump to this line to read the new instructions. !error $(MSG) |
| ︙ | ︙ | |||
727 728 729 730 731 732 733 | "$(SCRIPT_INSTALL_DIR)\http1.0\" @echo installing http2.4 @xcopy /i /y "$(ROOT)\library\http\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\http2.4\" @echo installing opt0.4 @xcopy /i /y "$(ROOT)\library\opt\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\opt0.4\" | | | > > > | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 | "$(SCRIPT_INSTALL_DIR)\http1.0\" @echo installing http2.4 @xcopy /i /y "$(ROOT)\library\http\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\http2.4\" @echo installing opt0.4 @xcopy /i /y "$(ROOT)\library\opt\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\opt0.4\" @echo installing msgcat1.3 @xcopy /i /y "$(ROOT)\library\msgcat\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\msgcat1.3\" @echo installing tcltest2.2 @xcopy /i /y "$(ROOT)\library\tcltest\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\tcltest2.2\" @echo installing $(TCLDDELIBNAME) !if $(STATIC_BUILD) @xcopy /i /y "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\" !else @xcopy /i /y "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" @xcopy /i /y "$(ROOT)\library\dde\pkgIndex.tcl" \ "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\" |
| ︙ | ︙ |
Changes to win/rules.vc.
1 2 3 4 5 6 7 8 9 10 11 12 | #------------------------------------------------------------------------------ # 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-2002 David Gravereaux. # #------------------------------------------------------------------------------ | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | #------------------------------------------------------------------------------ # 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-2002 David Gravereaux. # #------------------------------------------------------------------------------ # RCS: @(#) $Id: rules.vc,v 1.4.4.3 2002/08/20 20:25:31 das Exp $ #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 cc32 = $(CC) # built-in default. link32 = link |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | !endif #---------------------------------------------------------- # Test for compiler features #---------------------------------------------------------- ### test for optimizations | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | !endif #---------------------------------------------------------- # Test for compiler features #---------------------------------------------------------- ### test for optimizations !if [nmakehlp -c -Otip ] !message *** Compiler has 'Optimizations' OPTIMIZING = 1 !else !message *** Compiler doesn't have 'Optimizations' OPTIMIZING = 0 !endif |
| ︙ | ︙ |
Changes to win/tcl.rc.
|
| | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 | // RCS: @(#) $Id: tcl.rc,v 1.7.2.1 2002/08/20 20:25:31 das Exp $ // // Version Resource Script // #include <winver.h> #include <tcl.h> // // build-up the name suffix that defines the type of build this is. // #ifdef TCL_THREADS #define SUFFIX_THREADS "t" |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
BEGIN
VALUE "FileDescription", "Tcl DLL\0"
| | | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
BEGIN
VALUE "FileDescription", "Tcl DLL\0"
VALUE "OriginalFilename", "tcl" STRINGIFY(JOIN(TCL_MAJOR_VERSION,TCL_MINOR_VERSION)) SUFFIX ".dll\0"
VALUE "CompanyName", "ActiveState Corporation\0"
VALUE "FileVersion", TCL_PATCH_LEVEL
VALUE "LegalCopyright", "Copyright \251 2001 by ActiveState Corporation, et al\0"
VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
VALUE "ProductVersion", TCL_PATCH_LEVEL
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x409, 1200
END
END
|
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.9.18.3 2002/08/20 20:25:31 das Exp $ */ #include "tclWinInt.h" /* * The following data structures are used when loading the thunking * library for execing child processes under Win32s. |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
(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,
NULL,
};
static TclWinProcs unicodeProcs = {
1,
(BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW,
(TCHAR *(WINAPI *)(TCHAR *)) CharLowerW,
| > | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
(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,
NULL,
NULL,
};
static TclWinProcs unicodeProcs = {
1,
(BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW,
(TCHAR *(WINAPI *)(TCHAR *)) CharLowerW,
|
| ︙ | ︙ | |||
117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
(TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
(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,
NULL,
};
TclWinProcs *tclWinProcs;
static Tcl_Encoding tclWinTCharEncoding;
/*
| > | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
(TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
(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,
NULL,
NULL,
};
TclWinProcs *tclWinProcs;
static Tcl_Encoding tclWinTCharEncoding;
/*
|
| ︙ | ︙ | |||
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 |
tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
if (tclWinProcs->getFileAttributesExProc == NULL) {
HINSTANCE hInstance = LoadLibraryA("kernel32");
if (hInstance != NULL) {
tclWinProcs->getFileAttributesExProc =
(BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS,
LPVOID)) GetProcAddress(hInstance, "GetFileAttributesExW");
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");
FreeLibrary(hInstance);
}
}
}
}
/*
| > > > > > > > > | 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 |
tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
if (tclWinProcs->getFileAttributesExProc == NULL) {
HINSTANCE hInstance = LoadLibraryA("kernel32");
if (hInstance != NULL) {
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);
}
}
}
}
/*
|
| ︙ | ︙ |
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.15.8.3 2002/08/20 20:25:31 das Exp $ */ #include "tclWinInt.h" /* * State flags used in the info structures below. */ |
| ︙ | ︙ | |||
740 741 742 743 744 745 746 | * May open the channel and may cause creation of a file on the * file system. * *---------------------------------------------------------------------- */ Tcl_Channel | | | < | < < < < < | 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 |
* May open the channel and may cause creation of a file on the
* file system.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpOpenFileChannel(interp, pathPtr, mode, permissions)
Tcl_Interp *interp; /* Interpreter for error reporting;
* can be NULL. */
Tcl_Obj *pathPtr; /* Name of file to open. */
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, consoleParams, type;
CONST TCHAR *nativeName;
DCB dcb;
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL;
TclFile writeFile = NULL;
nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr);
if (nativeName == NULL) {
return NULL;
}
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
channel = NULL;
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
"bad file type", (char *) NULL);
break;
}
| < < < < < < < < < < < < < < | 927 928 929 930 931 932 933 934 935 936 937 938 939 940 |
channel = NULL;
Tcl_AppendResult(interp, "couldn't open \"",
Tcl_GetString(pathPtr), "\": ",
"bad file type", (char *) NULL);
break;
}
return channel;
}
/*
*----------------------------------------------------------------------
*
* Tcl_MakeFileChannel --
|
| ︙ | ︙ |
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.14.2.3 2002/08/20 20:25:31 das Exp $ */ #include "tclWinInt.h" /* * The following constants specify the type of callback when * TraverseWinTree() calls the traverseProc() |
| ︙ | ︙ | |||
562 563 564 565 566 567 568 569 570 571 572 573 574 575 |
dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
if (srcAttr != 0xffffffff) {
if (dstAttr == 0xffffffff) {
dstAttr = 0;
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
(*tclWinProcs->setFileAttributesProc)(nativeDst,
dstAttr & ~FILE_ATTRIBUTE_READONLY);
if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
return TCL_OK;
| > > > > > > | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
if (srcAttr != 0xffffffff) {
if (dstAttr == 0xffffffff) {
dstAttr = 0;
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* Source is a symbolic link -- copy it */
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == 0) {
return TCL_OK;
}
}
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
(*tclWinProcs->setFileAttributesProc)(nativeDst,
dstAttr & ~FILE_ATTRIBUTE_READONLY);
if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
return TCL_OK;
|
| ︙ | ︙ | |||
655 656 657 658 659 660 661 |
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
| > > > > > > > | > > | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* It is a symbolic link -- remove it */
if (TclWinSymLinkDelete(nativePath, 0) == 0) {
return TCL_OK;
}
}
/*
* If we fall through here, it is a directory.
*
* Windows NT reports removing a directory as EACCES instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
int res = (*tclWinProcs->setFileAttributesProc)(nativePath,
|
| ︙ | ︙ | |||
899 900 901 902 903 904 905 906 907 908 909 910 911 912 |
* EACCES, not an ENOTDIR.
*/
Tcl_SetErrno(ENOTDIR);
goto end;
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
goto end;
}
if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
| > > > > > > > | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 |
* EACCES, not an ENOTDIR.
*/
Tcl_SetErrno(ENOTDIR);
goto end;
}
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* It is a symbolic link -- remove it */
if (TclWinSymLinkDelete(nativePath, 1) != 0) {
goto end;
}
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
goto end;
}
if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
|
| ︙ | ︙ | |||
1808 1809 1810 1811 1812 1813 1814 |
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
Tcl_IncrRefCount(resultPtr);
return resultPtr;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1830 1831 1832 1833 1834 1835 1836 |
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
Tcl_IncrRefCount(resultPtr);
return resultPtr;
}
|
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 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 |
/*
* 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.17.2.3 2002/08/20 20:25:31 das Exp $
*/
//#define _WIN32_WINNT 0x0500
#include "tclWinInt.h"
#include <winioctl.h>
#include <sys/stat.h>
#include <shlobj.h>
#include <lmaccess.h> /* For TclpGetUserHome(). */
/*
* 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
#endif
#ifndef IO_REPARSE_TAG_RESERVED_RANGE
# define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001
#endif
#ifndef IO_REPARSE_TAG_VALID_VALUES
# define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF
#endif
#ifndef IO_REPARSE_TAG_HSM
# define IO_REPARSE_TAG_HSM 0x0C0000004
#endif
#ifndef IO_REPARSE_TAG_NSS
# define IO_REPARSE_TAG_NSS 0x080000005
#endif
#ifndef IO_REPARSE_TAG_NSSRECOVER
# define IO_REPARSE_TAG_NSSRECOVER 0x080000006
#endif
#ifndef IO_REPARSE_TAG_SIS
# define IO_REPARSE_TAG_SIS 0x080000007
#endif
#ifndef IO_REPARSE_TAG_DFS
# define IO_REPARSE_TAG_DFS 0x080000008
#endif
#ifndef IO_REPARSE_TAG_RESERVED_ZERO
# define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000
#endif
#ifndef FILE_FLAG_OPEN_REPARSE_POINT
# define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000
#endif
#ifndef IO_REPARSE_TAG_MOUNT_POINT
# define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003
#endif
#ifndef IsReparseTagValid
# define IsReparseTagValid(x) (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE))
#endif
#ifndef IO_REPARSE_TAG_SYMBOLIC_LINK
# define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO
#endif
#ifndef FILE_SPECIAL_ACCESS
# 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
/*
* Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition.
* This is found in winnt.h.
*
* IMPORTANT: caution when using this structure, since the actual
* structures used will want to store a full path in the 'PathBuffer'
* field, but there isn't room (there's only a single WCHAR!). Therefore
* one must artificially create a larger space of memory and then cast it
* to this type. We use the 'DUMMY_REPARSE_BUFFER' struct just below to
* deal with this problem.
*/
#define REPARSE_MOUNTPOINT_HEADER_SIZE 8
#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE
typedef struct _REPARSE_DATA_BUFFER {
DWORD ReparseTag;
WORD ReparseDataLength;
WORD Reserved;
union {
struct {
WORD SubstituteNameOffset;
WORD SubstituteNameLength;
WORD PrintNameOffset;
WORD PrintNameLength;
WCHAR PathBuffer[1];
} SymbolicLinkReparseBuffer;
struct {
WORD SubstituteNameOffset;
WORD SubstituteNameLength;
WORD PrintNameOffset;
WORD PrintNameLength;
WCHAR PathBuffer[1];
} MountPointReparseBuffer;
struct {
BYTE DataBuffer[1];
} GenericReparseBuffer;
};
} 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);
typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
(LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
/*
* Declarations for local procedures defined in this file:
*/
static int NativeAccess(CONST TCHAR *path, int mode);
static int NativeStat(CONST TCHAR *path, Tcl_StatBuf *statPtr, int checkLinks);
static int NativeIsExec(CONST TCHAR *path);
static int NativeReadReparse(CONST TCHAR* LinkDirectory,
REPARSE_DATA_BUFFER* buffer);
static int NativeWriteReparse(CONST TCHAR* LinkDirectory,
REPARSE_DATA_BUFFER* buffer);
static int NativeMatchType(CONST char *name, int nameLen,
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);
/*
*--------------------------------------------------------------------
*
* WinLink
*
* Make a link from source to target.
*--------------------------------------------------------------------
*/
static int
WinLink(LinkSource, LinkTarget, linkAction)
CONST TCHAR* LinkSource;
CONST TCHAR* LinkTarget;
int linkAction;
{
WCHAR tempFileName[MAX_PATH];
TCHAR* tempFilePart;
int attr;
/* Get the full path referenced by the target */
if (!(*tclWinProcs->getFullPathNameProc)(LinkTarget,
MAX_PATH, tempFileName, &tempFilePart)) {
/* Invalid file */
TclWinConvertError(GetLastError());
return -1;
}
/* Make sure source file doesn't exist */
attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
if (attr != 0xffffffff) {
Tcl_SetErrno(EEXIST);
return -1;
}
/* Get the full path referenced by the directory */
if (!(*tclWinProcs->getFullPathNameProc)(LinkSource,
MAX_PATH, tempFileName, &tempFilePart)) {
/* Invalid file */
TclWinConvertError(GetLastError());
return -1;
}
/* Check the target */
attr = (*tclWinProcs->getFileAttributesProc)(LinkTarget);
if (attr == 0xffffffff) {
/* The target doesn't exist */
TclWinConvertError(GetLastError());
return -1;
} else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/* It is a file */
if (tclWinProcs->createHardLinkProc == NULL) {
Tcl_SetErrno(ENOTDIR);
return -1;
}
if (linkAction & TCL_CREATE_HARD_LINK) {
if (!(*tclWinProcs->createHardLinkProc)(LinkSource, LinkTarget, NULL)) {
TclWinConvertError(GetLastError());
return -1;
}
return 0;
} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
/* Can't symlink files */
Tcl_SetErrno(ENOTDIR);
return -1;
} else {
Tcl_SetErrno(ENODEV);
return -1;
}
} else {
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
return WinSymLinkDirectory(LinkSource, LinkTarget);
} else if (linkAction & TCL_CREATE_HARD_LINK) {
/* Can't hard link directories */
Tcl_SetErrno(EISDIR);
return -1;
} else {
Tcl_SetErrno(ENODEV);
return -1;
}
}
}
/*
*--------------------------------------------------------------------
*
* WinReadLink
*
* What does 'LinkSource' point to? We need the original 'pathPtr'
* just so we can construct a path object in the correct filesystem.
*--------------------------------------------------------------------
*/
static Tcl_Obj*
WinReadLink(LinkSource)
CONST TCHAR* LinkSource;
{
WCHAR tempFileName[MAX_PATH];
TCHAR* tempFilePart;
int attr;
/* Get the full path referenced by the target */
if (!(*tclWinProcs->getFullPathNameProc)(LinkSource,
MAX_PATH, tempFileName, &tempFilePart)) {
/* Invalid file */
TclWinConvertError(GetLastError());
return NULL;
}
/* Make sure source file does exist */
attr = (*tclWinProcs->getFileAttributesProc)(LinkSource);
if (attr == 0xffffffff) {
/* The source doesn't exist */
TclWinConvertError(GetLastError());
return NULL;
} else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/* It is a file - this is not yet supported */
Tcl_SetErrno(ENOTDIR);
return NULL;
} else {
return WinReadLinkDirectory(LinkSource);
}
}
/*
*--------------------------------------------------------------------
*
* WinSymLinkDirectory
*
* This routine creates a NTFS junction, using the undocumented
* FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points
* and junctions.
*
* Assumption that LinkTarget is a valid, existing directory.
*
* Returns zero on success.
*--------------------------------------------------------------------
*/
static int
WinSymLinkDirectory(LinkDirectory, LinkTarget)
CONST TCHAR* LinkDirectory;
CONST TCHAR* LinkTarget;
{
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
int len;
WCHAR nativeTarget[MAX_PATH];
WCHAR *loop;
/* Make the native target name */
memcpy((VOID*)nativeTarget, (VOID*)L"\\??\\", 4*sizeof(WCHAR));
memcpy((VOID*)(nativeTarget + 4), (VOID*)LinkTarget,
sizeof(WCHAR)*(1+wcslen((WCHAR*)LinkTarget)));
len = wcslen(nativeTarget);
/*
* We must have backslashes only. This is VERY IMPORTANT.
* If we have any forward slashes everything appears to work,
* but the resulting symlink is useless!
*/
for (loop = nativeTarget; *loop != 0; loop++) {
if (*loop == L'/') *loop = L'\\';
}
if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) {
nativeTarget[len-1] = 0;
}
/* Build the reparse info */
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength =
wcslen(nativeTarget) * sizeof(WCHAR);
reparseBuffer->Reserved = 0;
reparseBuffer->SymbolicLinkReparseBuffer.PrintNameLength = 0;
reparseBuffer->SymbolicLinkReparseBuffer.PrintNameOffset =
reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength
+ sizeof(WCHAR);
memcpy(reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer, nativeTarget,
sizeof(WCHAR)
+ reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength);
reparseBuffer->ReparseDataLength =
reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength + 12;
return NativeWriteReparse(LinkDirectory, reparseBuffer);
}
/*
*--------------------------------------------------------------------
*
* TclWinSymLinkCopyDirectory
*
* Copy a Windows NTFS junction. This function assumes that
* LinkOriginal exists and is a valid junction point, and that
* LinkCopy does not exist.
*
* Returns zero on success.
*--------------------------------------------------------------------
*/
int
TclWinSymLinkCopyDirectory(LinkOriginal, LinkCopy)
CONST TCHAR* LinkOriginal; /* Existing junction - reparse point */
CONST TCHAR* LinkCopy; /* Will become a duplicate junction */
{
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
if (NativeReadReparse(LinkOriginal, reparseBuffer)) {
return -1;
}
return NativeWriteReparse(LinkCopy, reparseBuffer);
}
/*
*--------------------------------------------------------------------
*
* TclWinSymLinkDelete
*
* Delete a Windows NTFS junction. Once the junction information
* is deleted, the filesystem object becomes an ordinary directory.
* Unless 'linkOnly' is given, that directory is also removed.
*
* Assumption that LinkOriginal is a valid, existing junction.
*
* Returns zero on success.
*--------------------------------------------------------------------
*/
int
TclWinSymLinkDelete(LinkOriginal, linkOnly)
CONST TCHAR* LinkOriginal;
int linkOnly;
{
/* It is a symbolic link -- remove it */
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
HANDLE hFile;
int returnedLength;
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
hFile = (*tclWinProcs->createFileProc)(LinkOriginal, GENERIC_WRITE, 0,
NULL, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
REPARSE_MOUNTPOINT_HEADER_SIZE,
NULL, 0, &returnedLength, NULL)) {
/* Error setting junction */
TclWinConvertError(GetLastError());
CloseHandle(hFile);
} else {
CloseHandle(hFile);
if (!linkOnly) {
(*tclWinProcs->removeDirectoryProc)(LinkOriginal);
}
return 0;
}
}
return -1;
}
/*
*--------------------------------------------------------------------
*
* WinReadLinkDirectory
*
* 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).
*--------------------------------------------------------------------
*/
static Tcl_Obj*
WinReadLinkDirectory(LinkDirectory)
CONST TCHAR* LinkDirectory;
{
int attr;
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER*)&dummy;
attr = (*tclWinProcs->getFileAttributesProc)(LinkDirectory);
if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
Tcl_SetErrno(EINVAL);
return NULL;
}
if (NativeReadReparse(LinkDirectory, reparseBuffer)) {
return NULL;
}
switch (reparseBuffer->ReparseTag) {
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;
Tcl_WinTCharToUtf(
(CONST char*)reparseBuffer->SymbolicLinkReparseBuffer.PathBuffer,
(int)reparseBuffer->SymbolicLinkReparseBuffer.SubstituteNameLength,
&ds);
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
/*
* Certain native path representations on Windows have this special
* prefix to indicate that they are to be treated specially. For
* example extremely long paths, or symlinks
*/
if (*copy == '\\') {
if (0 == strncmp(copy,"\\??\\",4)) {
copy += 4;
len -= 4;
} else if (0 == strncmp(copy,"\\\\?\\",4)) {
copy += 4;
len -= 4;
}
}
retVal = Tcl_NewStringObj(copy,len);
Tcl_IncrRefCount(retVal);
Tcl_DStringFree(&ds);
return retVal;
}
}
Tcl_SetErrno(EINVAL);
return NULL;
}
/*
*--------------------------------------------------------------------
*
* NativeReadReparse
*
* Read the junction/reparse information from a given NTFS directory.
*
* Assumption that LinkDirectory is a valid, existing directory.
*
* Returns zero on success.
*--------------------------------------------------------------------
*/
static int
NativeReadReparse(LinkDirectory, buffer)
CONST TCHAR* LinkDirectory; /* The junction to read */
REPARSE_DATA_BUFFER* buffer; /* Pointer to buffer. Cannot be NULL */
{
HANDLE hFile;
int returnedLength;
hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_READ, 0,
NULL, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/* Error creating directory */
TclWinConvertError(GetLastError());
return -1;
}
/* Get the link */
if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL,
0, buffer, sizeof(DUMMY_REPARSE_BUFFER),
&returnedLength, NULL)) {
/* Error setting junction */
TclWinConvertError(GetLastError());
CloseHandle(hFile);
return -1;
}
CloseHandle(hFile);
if (!IsReparseTagValid(buffer->ReparseTag)) {
Tcl_SetErrno(EINVAL);
return -1;
}
return 0;
}
/*
*--------------------------------------------------------------------
*
* NativeWriteReparse
*
* Write the reparse information for a given directory.
*
* Assumption that LinkDirectory does not exist.
*--------------------------------------------------------------------
*/
static int
NativeWriteReparse(LinkDirectory, buffer)
CONST TCHAR* LinkDirectory;
REPARSE_DATA_BUFFER* buffer;
{
HANDLE hFile;
int returnedLength;
/* Create the directory - it must not already exist */
if ((*tclWinProcs->createDirectoryProc)(LinkDirectory, NULL) == 0) {
/* Error creating directory */
TclWinConvertError(GetLastError());
return -1;
}
hFile = (*tclWinProcs->createFileProc)(LinkDirectory, GENERIC_WRITE, 0,
NULL, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/* Error creating directory */
TclWinConvertError(GetLastError());
return -1;
}
/* Set the link */
if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer,
buffer->ReparseDataLength
+ REPARSE_MOUNTPOINT_HEADER_SIZE,
NULL, 0, &returnedLength, NULL)) {
/* Error setting junction */
TclWinConvertError(GetLastError());
CloseHandle(hFile);
(*tclWinProcs->removeDirectoryProc)(LinkDirectory);
return -1;
}
CloseHandle(hFile);
/* We succeeded */
return 0;
}
/*
*---------------------------------------------------------------------------
*
* TclpFindExecutable --
*
* This procedure computes the absolute path name of the current
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 |
) {
return 0;
}
}
if (types->type != 0) {
Tcl_StatBuf buf;
| | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 |
) {
return 0;
}
}
if (types->type != 0) {
Tcl_StatBuf buf;
if (NativeStat(nativeName, &buf, 0) != 0) {
/*
* Posix error occurred, either the file
* has disappeared, or there is some other
* strange error. In any case we don't
* return this file.
*/
return 0;
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
S_ISSOCK(buf.st_mode))
#endif
) {
/* Do nothing -- this file is ok */
} else {
#ifdef S_ISLNK
if (types->type & TCL_GLOB_TYPE_LINK) {
| < < < < | | 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 |
S_ISSOCK(buf.st_mode))
#endif
) {
/* Do nothing -- this file is ok */
} else {
#ifdef S_ISLNK
if (types->type & TCL_GLOB_TYPE_LINK) {
if (NativeStat(nativeName, &buf, 1) == 0) {
if (S_ISLNK(buf.st_mode)) {
return 1;
}
}
}
#endif
return 0;
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 |
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
length = readlink(native, link, sizeof(link)); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (length < 0) {
| | | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 |
Tcl_DString ds;
native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
length = readlink(native, link, sizeof(link)); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
return Tcl_DStringValue(linkPtr);
}
#endif /* __CYGWIN__ */
|
| ︙ | ︙ | |||
945 946 947 948 949 950 951 |
* 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.
*/
TclWinFlushDirtyChannels ();
| | | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 |
* 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.
*/
TclWinFlushDirtyChannels ();
return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}
/*
*----------------------------------------------------------------------
*
* NativeStat --
*
|
| ︙ | ︙ | |||
972 973 974 975 976 977 978 | * Side effects: * See stat documentation. * *---------------------------------------------------------------------- */ static int | | > | 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 |
* Side effects:
* See stat documentation.
*
*----------------------------------------------------------------------
*/
static int
NativeStat(nativePath, statPtr, checkLinks)
CONST TCHAR *nativePath; /* Path of file to stat */
Tcl_StatBuf *statPtr; /* Filled with results of stat call. */
int checkLinks; /* If non-zero, behave like 'lstat' */
{
Tcl_DString ds;
DWORD attr;
WCHAR nativeFullPath[MAX_PATH];
TCHAR *nativePart;
CONST char *fullPath;
int dev, mode;
|
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 |
statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) |
(((Tcl_WideInt)data.nFileSizeHigh) << 32);
statPtr->st_atime = ToCTime(data.ftLastAccessTime);
statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
statPtr->st_ctime = ToCTime(data.ftCreationTime);
}
| > > > > | > | | 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 |
statPtr->st_size = ((Tcl_WideInt)data.nFileSizeLow) |
(((Tcl_WideInt)data.nFileSizeHigh) << 32);
statPtr->st_atime = ToCTime(data.ftLastAccessTime);
statPtr->st_mtime = ToCTime(data.ftLastWriteTime);
statPtr->st_ctime = ToCTime(data.ftCreationTime);
}
if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
/* It is a link */
mode = S_IFLNK;
} else {
mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
}
mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
if (NativeIsExec(nativePath)) {
mode |= S_IEXEC;
}
/*
* Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
* other positions.
*/
mode |= (mode & 0x0700) >> 3;
mode |= (mode & 0x0700) >> 6;
|
| ︙ | ︙ | |||
1308 1309 1310 1311 1312 1313 1314 |
Tcl_Obj *pathPtr;
int mode;
{
return NativeAccess((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), mode);
}
int
| | | > > > > > | > > > | > > > > > > | | > > | > | > < | | < < | > < | 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 |
Tcl_Obj *pathPtr;
int mode;
{
return NativeAccess((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), mode);
}
int
TclpObjLstat(pathPtr, statPtr)
Tcl_Obj *pathPtr;
Tcl_StatBuf *statPtr;
{
/*
* 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.
*/
TclWinFlushDirtyChannels ();
return NativeStat((CONST TCHAR*) Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}
#ifdef S_IFLNK
Tcl_Obj*
TclpObjLink(pathPtr, toPtr, linkAction)
Tcl_Obj *pathPtr;
Tcl_Obj *toPtr;
int linkAction;
{
if (toPtr != NULL) {
int res;
TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(toPtr);
TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
if (LinkSource == NULL || LinkTarget == NULL) {
return NULL;
}
res = WinLink(LinkSource, LinkTarget, linkAction);
if (res == 0) {
return toPtr;
} else {
return NULL;
}
} else {
TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
if (LinkSource == NULL) {
return NULL;
}
return WinReadLink(LinkSource);
}
}
#endif
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1400 1401 1402 1403 1404 1405 1406 |
Tcl_WinTCharToUtf(volType, -1, &ds);
objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
return objPtr;
}
#undef VOL_BUF_SIZE
}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
Tcl_WinTCharToUtf(volType, -1, &ds);
objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
Tcl_DStringFree(&ds);
return objPtr;
}
#undef VOL_BUF_SIZE
}
/*
*---------------------------------------------------------------------------
*
* TclpObjNormalizePath --
*
* This function scans through a path specification and replaces it,
* in place, with a normalized version. This means using the
* 'longname', and expanding any symbolic links contained within the
* path.
*
* Results:
* The new 'nextCheckpoint' value, giving as far as we could
* understand in the path.
*
* Side effects:
* The pathPtr string, which must contain a valid path, is
* possibly modified in place.
*
*---------------------------------------------------------------------------
*/
int
TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
Tcl_Interp *interp;
Tcl_Obj *pathPtr;
int nextCheckpoint;
{
char *lastValidPathEnd = NULL;
/* This will hold the normalized string */
Tcl_DString dsNorm;
char *path;
char *currentPathEndPosition;
Tcl_DStringInit(&dsNorm);
path = Tcl_GetString(pathPtr);
if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) {
/*
* We're on Win95, 98 or ME. There are two assumptions
* in this block of code. First that the native (NULL)
* encoding is basically ascii, and second that symbolic
* links are not possible. Both of these assumptions
* appear to be true of these operating systems.
*/
Tcl_Obj *temp = NULL;
int isDrive = 1;
Tcl_DString ds;
currentPathEndPosition = path + nextCheckpoint;
while (1) {
char cur = *currentPathEndPosition;
if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
/* Reached directory separator, or end of string */
CONST char *nativePath = Tcl_UtfToExternalDString(NULL, path,
currentPathEndPosition - path, &ds);
/*
* 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)
== 0xffffffff) {
/* File doesn't exist */
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)
== 0xffffffff) {
/* File doesn't exist */
Tcl_DStringFree(&ds);
break;
}
/* This is usually the '/' in 'c:/' at end of string */
Tcl_DStringAppend(&dsNorm,"/", 1);
} else {
char *nativeName;
if (fData.cFileName[0] != '\0') {
nativeName = fData.cFileName;
} else {
nativeName = fData.cAlternateFileName;
}
FindClose(handle);
Tcl_DStringAppend(&dsNorm,"/", 1);
Tcl_DStringAppend(&dsNorm,nativeName,-1);
}
}
Tcl_DStringFree(&ds);
lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
break;
}
/*
* If we get here, we've got past one directory
* delimiter, so we know it is no longer a drive
*/
isDrive = 0;
}
currentPathEndPosition++;
}
} else {
/* We're on WinNT or 2000 or XP */
Tcl_Obj *temp = NULL;
int isDrive = 1;
Tcl_DString ds;
currentPathEndPosition = path + nextCheckpoint;
while (1) {
char cur = *currentPathEndPosition;
if ((cur == '/' || cur == 0) && (path != currentPathEndPosition)) {
/* 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
* continue with the rest of the path.
*/
/*
* Check for symlinks, except at last component
* of path (we don't follow final symlinks). Also
* a drive (C:/) for example, may sometimes have
* the reparse flag set for some reason I don't
* understand. We therefore don't perform this
* check for drives.
*/
if (cur != 0 && !isDrive && (data.dwFileAttributes
& FILE_ATTRIBUTE_REPARSE_POINT)) {
Tcl_Obj *to = WinReadLinkDirectory(nativePath);
if (to != NULL) {
/* Read the reparse point ok */
/* Tcl_GetStringFromObj(to, &pathLen); */
nextCheckpoint = 0; /* pathLen */
Tcl_AppendToObj(to, currentPathEndPosition, -1);
/* Convert link to forward slashes */
for (path = Tcl_GetString(to); *path != 0; path++) {
if (*path == '\\') *path = '/';
}
path = Tcl_GetString(to);
currentPathEndPosition = path + nextCheckpoint;
if (temp != NULL) {
Tcl_DecrRefCount(temp);
}
temp = to;
/* Reset variables so we can restart normalization */
isDrive = 1;
Tcl_DStringFree(&dsNorm);
Tcl_DStringInit(&dsNorm);
Tcl_DStringFree(&ds);
continue;
}
}
/*
* 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 (isDrive) {
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 {
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,
wcslen(nativeName)*sizeof(WCHAR));
}
}
Tcl_DStringFree(&ds);
lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
break;
}
/*
* If we get here, we've got past one directory
* delimiter, so we know it is no longer a drive
*/
isDrive = 0;
}
currentPathEndPosition++;
}
}
/* Common code path for all Windows platforms */
nextCheckpoint = currentPathEndPosition - path;
if (lastValidPathEnd != NULL) {
/*
* Concatenate the normalized string in dsNorm with the
* tail of the path which we didn't recognise. The
* string in dsNorm is in the native encoding, so we
* have to convert it to Utf.
*/
Tcl_DString dsTemp;
Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm),
Tcl_DStringLength(&dsNorm), &dsTemp);
nextCheckpoint = Tcl_DStringLength(&dsTemp);
if (*lastValidPathEnd != 0) {
/* Not the end of the string */
int len;
char *path;
Tcl_Obj *tmpPathPtr;
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
path = Tcl_GetStringFromObj(tmpPathPtr, &len);
Tcl_SetStringObj(pathPtr, path, len);
Tcl_DecrRefCount(tmpPathPtr);
} else {
/* End of string was reached above */
Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
nextCheckpoint);
}
Tcl_DStringFree(&dsTemp);
}
Tcl_DStringFree(&dsNorm);
return nextCheckpoint;
}
|
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 | /* * 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.11.6.3 2002/08/20 20:25:31 das Exp $ */ #ifndef _TCLWININT #define _TCLWININT #ifndef _TCLINT #include "tclInt.h" |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 |
BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *);
DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *,
CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *,
GET_FILEEX_INFO_LEVELS, LPVOID);
| | > > > > > > > > > > | 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 |
BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *);
DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *,
CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *,
GET_FILEEX_INFO_LEVELS, LPVOID);
BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*,
LPSECURITY_ATTRIBUTES);
} TclWinProcs;
EXTERN TclWinProcs *tclWinProcs;
/*
* Declarations of functions that are not accessible by way of the
* stubs table.
*/
EXTERN void TclWinInit(HINSTANCE hInst);
EXTERN int TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal,
CONST TCHAR* LinkCopy);
EXTERN int TclWinSymLinkDelete(CONST TCHAR* LinkOriginal,
int linkOnly);
#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 */
/* Needed by tclWinFile.c and tclWinFCmd.c */
#ifndef FILE_ATTRIBUTE_REPARSE_POINT
#define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400
#endif
#include "tclIntPlatDecls.h"
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLWININT */
|
Changes to win/tclWinLoad.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclWinLoad.c -- * * This procedure provides a version of the TclLoadFile that * works with the Windows "LoadLibrary" and "GetProcAddress" * API 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 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 |
/*
* tclWinLoad.c --
*
* This procedure provides a version of the TclLoadFile that
* works with the Windows "LoadLibrary" and "GetProcAddress"
* API 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: tclWinLoad.c,v 1.9.2.2 2002/08/20 20:25:31 das Exp $
*/
#include "tclWinInt.h"
/*
*----------------------------------------------------------------------
*
* 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 interp's result.
*
* Side effects:
* New code suddenly appears in memory.
*
*----------------------------------------------------------------------
*/
int
TclpDlopen(interp, pathPtr, loadHandle, unloadProcPtr)
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. */
{
HINSTANCE handle;
CONST TCHAR *nativeName;
Tcl_DString ds;
char *fileName = Tcl_GetString(pathPtr);
nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
handle = (*tclWinProcs->loadLibraryProc)(nativeName);
Tcl_DStringFree(&ds);
*loadHandle = (Tcl_LoadHandle) handle;
if (handle == NULL) {
DWORD lastError = GetLastError();
#if 0
/*
* It would be ideal if the FormatMessage stuff worked better,
* but unfortunately it doesn't seem to want to...
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
Tcl_AppendResult(interp, Tcl_PosixError(interp),
(char *) NULL);
}
return TCL_ERROR;
} else {
*unloadProcPtr = &TclpUnloadFile;
}
| > > > | > > > > > > > > > > > > > > > > > > > > > > > > | | | < < | < < < < | | | | 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 |
Tcl_AppendResult(interp, Tcl_PosixError(interp),
(char *) NULL);
}
return TCL_ERROR;
} else {
*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.
*
*----------------------------------------------------------------------
*/
Tcl_PackageInitProc*
TclpFindSymbol(interp, loadHandle, symbol)
Tcl_Interp *interp;
Tcl_LoadHandle loadHandle;
CONST char *symbol;
{
Tcl_PackageInitProc *proc = NULL;
HINSTANCE handle = (HINSTANCE)loadHandle;
/*
* For each symbol, check for both Symbol and _Symbol, since Borland
* generates C symbols with a leading '_' by default.
*/
proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
if (proc == NULL) {
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "_", 1);
symbol = Tcl_DStringAppend(&ds, symbol, -1);
proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol);
Tcl_DStringFree(&ds);
}
return proc;
}
/*
*----------------------------------------------------------------------
*
* TclpUnloadFile --
*
|
| ︙ | ︙ | |||
155 156 157 158 159 160 161 | * Side effects: * Code removed from memory. * *---------------------------------------------------------------------- */ void | | | | | | 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
* Side effects:
* Code removed from memory.
*
*----------------------------------------------------------------------
*/
void
TclpUnloadFile(loadHandle)
Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
* to TclpDlopen(). The loadHandle is
* a token that represents the loaded
* file. */
{
HINSTANCE handle;
handle = (HINSTANCE) loadHandle;
FreeLibrary(handle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
|
| ︙ | ︙ |
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.20.8.3 2002/08/20 20:25:31 das Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> |
| ︙ | ︙ | |||
1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 |
Tcl_DStringAppend(&ds, start, special - start);
start = special;
}
if (*special == '"') {
Tcl_DStringAppend(&ds, start, special - start);
Tcl_DStringAppend(&ds, "\\\"", 2);
start = special + 1;
}
if (*special == '\0') {
break;
}
special++;
}
Tcl_DStringAppend(&ds, start, special - start);
| > > > > > | 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 |
Tcl_DStringAppend(&ds, start, special - start);
start = special;
}
if (*special == '"') {
Tcl_DStringAppend(&ds, start, special - start);
Tcl_DStringAppend(&ds, "\\\"", 2);
start = special + 1;
}
if (*special == '{') {
Tcl_DStringAppend(&ds, start, special - start);
Tcl_DStringAppend(&ds, "\\{", 2);
start = special + 1;
}
if (*special == '\0') {
break;
}
special++;
}
Tcl_DStringAppend(&ds, start, special - start);
|
| ︙ | ︙ |
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.23.2.3 2002/08/20 20:25:31 das Exp $ */ #ifndef _TCLWINPORT #define _TCLWINPORT #ifndef _TCLINT # include "tclInt.h" |
| ︙ | ︙ | |||
278 279 280 281 282 283 284 285 286 287 288 289 290 291 | # define R_OK 04 #endif /* * Define macros to query file type bits, if they're not already * defined. */ #ifndef S_ISREG # ifdef S_IFREG # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) # else # define S_ISREG(m) 0 # endif | > > > > | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | # define R_OK 04 #endif /* * Define macros to query file type bits, if they're not already * defined. */ #ifndef S_IFLNK #define S_IFLNK 0120000 /* Symbolic Link */ #endif #ifndef S_ISREG # ifdef S_IFREG # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) # else # define S_ISREG(m) 0 # endif |
| ︙ | ︙ | |||
314 315 316 317 318 319 320 321 322 323 324 325 326 327 | #ifndef S_ISFIFO # ifdef S_IFIFO # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) # else # define S_ISFIFO(m) 0 # endif #endif /* !S_ISFIFO */ /* * Define MAXPATHLEN in terms of MAXPATH if available */ #ifndef MAXPATH #define MAXPATH MAX_PATH | > > > > > > > > | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 | #ifndef S_ISFIFO # ifdef S_IFIFO # define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) # else # define S_ISFIFO(m) 0 # endif #endif /* !S_ISFIFO */ #ifndef S_ISLNK # ifdef S_IFLNK # define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) # else # define S_ISLNK(m) 0 # endif #endif /* !S_ISLNK */ /* * Define MAXPATHLEN in terms of MAXPATH if available */ #ifndef MAXPATH #define MAXPATH MAX_PATH |
| ︙ | ︙ | |||
426 427 428 429 430 431 432 433 434 435 436 437 438 439 | * file tclWinSock.c). */ #define getservbyname TclWinGetServByName #define getsockopt TclWinGetSockOpt #define ntohs TclWinNToHS #define setsockopt TclWinSetSockOpt /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. */ #define TclpReleaseFile(file) ckfree((char *) file) | > > > | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 | * file tclWinSock.c). */ #define getservbyname TclWinGetServByName #define getsockopt TclWinGetSockOpt #define ntohs TclWinNToHS #define setsockopt TclWinSetSockOpt /* This type is not defined in the Windows headers */ #define socklen_t int /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. */ #define TclpReleaseFile(file) ckfree((char *) file) |
| ︙ | ︙ |
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.13.8.2 2002/08/20 20:25:31 das Exp $ */ #include "tclWinInt.h" #include <fcntl.h> #include <io.h> #include <sys/stat.h> |
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
* all events. */
SerialInfo *infoPtr; /* Pointer to serial info structure. Note
* that we still have to verify that the
* serial exists before dereferencing this
* pointer. */
} SerialEvent;
| > | > > > | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
* all events. */
SerialInfo *infoPtr; /* Pointer to serial info structure. Note
* that we still have to verify that the
* serial exists before dereferencing this
* pointer. */
} SerialEvent;
/*
* We don't use timeouts.
*/
static COMMTIMEOUTS no_timeout = {
0, /* ReadIntervalTimeout */
0, /* ReadTotalTimeoutMultiplier */
0, /* ReadTotalTimeoutConstant */
0, /* WriteTotalTimeoutMultiplier */
0, /* WriteTotalTimeoutConstant */
};
|
| ︙ | ︙ |
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 | /* * 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.5.14.2 2002/08/20 20:25:31 das Exp $ */ #define USE_COMPAT_CONST #include "tclWinInt.h" /* * Forward declarations of procedures defined later in this file: */ int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp)); static int TesteventloopCmd _ANSI_ARGS_((ClientData dummy, |
| ︙ | ︙ |
Changes to win/tclsh.rc.
|
| | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 | // RCS: @(#) $Id: tclsh.rc,v 1.7.2.1 2002/08/20 20:25:31 das Exp $ // // Version Resource Script // #include <winver.h> #include <tcl.h> // // build-up the name suffix that defines the type of build this is. // #ifdef TCL_THREADS #define SUFFIX_THREADS "t" |
| ︙ | ︙ | |||
48 49 50 51 52 53 54 |
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "Tclsh Application\0"
| | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "Tclsh Application\0"
VALUE "OriginalFilename", "tclsh" STRINGIFY(JOIN(TCL_MAJOR_VERSION,TCL_MINOR_VERSION)) SUFFIX ".exe\0"
VALUE "CompanyName", "ActiveState Corporation\0"
VALUE "FileVersion", TCL_PATCH_LEVEL
VALUE "LegalCopyright", "Copyright \251 2000 by ActiveState Corporation, et al\0"
VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
VALUE "ProductVersion", TCL_PATCH_LEVEL
END
END
|
| ︙ | ︙ |